emacs_el/tiny-tools/tiny/tinylibo.el

   1 ;;; tinylibo.el --- Library for handling (o)verlays
   2
   3 ;; This file is not part of Emacs
   4
   5 ;;{{{ Id
   6
   7 ;; Copyright (C)    1995-2007 Jari Aalto
   8 ;; Keywords:        extensions
   9 ;; Author:          Jari Aalto
  10 ;; Maintainer:      Jari Aalto
  11 ;;
  12 ;; To get information on this program, call M-x tinylibo-version.
  13 ;; Look at the code with folding.el
  14
  15 ;; COPYRIGHT NOTICE
  16 ;;
  17 ;; This program is free software; you can redistribute it and/or modify it
  18 ;; under the terms of the GNU General Public License as published by the Free
  19 ;; Software Foundation; either version 2 of the License, or (at your option)
  20 ;; any later version.
  21 ;;
  22 ;; This program is distributed in the hope that it will be useful, but
  23 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  24 ;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  25 ;; for more details.
  26 ;;
  27 ;; You should have received a copy of the GNU General Public License
  28 ;; along with program; see the file COPYING. If not, write to the
  29 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  30 ;; Boston, MA 02110-1301, USA.
  31 ;;
  32 ;; Visit <http://www.gnu.org/copyleft/gpl.html> for more information
  33
  34 ;;}}}
  35 ;;{{{ Install
  36
  37 ;;; Intallation:
  38
  39 ;; ........................................................ &t-install ...
  40 ;; Put this file on your Emacs-Lisp load path, add following into your
  41 ;; ~/.emacs startup file. Yes, you require 'm' lib which publishes
  42 ;; this modules interface.
  43 ;;
  44 ;;     (require 'tinylibm)
  45
  46 ;;}}}
  47 ;;{{{ Documentation
  48
  49 ;; ..................................................... &t-commentary ...
  50
  51 ;;; Commentary:
  52
  53 ;;  Preface 1995
  54 ;;
  55 ;;      The functions were developed to ease the highlighting,
  56 ;;      at the time when these function were new in Emacs. The overlays
  57 ;;      really seemed like "inside" stuff when tried for the first time
  58 ;;      to make text colored.
  59 ;;
  60 ;;      o   This is LIBRARY module, it does nothing on its own.
  61 ;;      o   Offers functions for overlay handling
  62
  63 ;;}}}
  64
  65 ;;; Change Log:
  66
  67 ;;; Code:
  68
  69 ;;{{{ setup: -- require
  70
  71 ;;; ......................................................... &require ...
  72
  73 (require 'tinylibm)
  74
  75 (ti::package-use-dynamic-compilation)
  76
  77 (eval-and-compile
  78   (ti::overlay-require-macro
  79     (message "\n\
  80 tinylibo: ** XEmacs needs overlay.el package; emulation may not work.")
  81
  82     ;; Idea in setnu.el, note that XEmacs 19.15+ includes an overlay.el
  83
  84     (unless (fboundp 'overlayp)
  85       (defalias 'overlayp               'extent-live-p))
  86
  87     (unless (fboundp 'make-overlay)
  88       (defalias 'make-overlay           'make-extent))
  89
  90     (unless (fboundp 'delete-overlay)
  91       (defalias 'delete-overlay 'delete-extent))
  92
  93     (unless (fboundp 'overlay-get)
  94       (defalias 'overlay-get            'extent-property))
  95
  96     (unless (fboundp 'overlay-put)
  97       (defalias 'overlay-put            'set-extent-property))
  98
  99     (unless (fboundp 'move-overlay)
 100       (defalias 'move-overlay           'set-extent-endpoints))
 101
 102     (unless (fboundp 'overlay-end)
 103       (defalias 'overlay-end            'extent-end-position))
 104
 105     (unless (fboundp 'overlay-start)
 106       (defalias 'overlay-start  'extent-start-position))
 107
 108     (unless (fboundp 'overlay-buffer)
 109       (defalias 'overlay-buffer 'extent-start-position))
 110
 111     (unless (fboundp 'overlay-buffer)
 112       (defalias 'overlay-buffer 'extent-start-position))
 113
 114     (unless (fboundp 'next-overlay-change)
 115       (defalias 'next-overlay-change  'next-extent-change))
 116
 117     (unless (fboundp 'overlay-properties)
 118       (defalias 'overlay-properties   'extent-properties))
 119
 120     (unless (fboundp 'overlay-length)
 121       (defalias 'overlay-length 'extent-length))
 122
 123     (unless (fboundp 'overlays-at)
 124       (defun overlays-at (point)
 125         "tinylibo.el -- return overlay at POINT."
 126         (ti::funcall 'extent-list (current-buffer) point)))))
 127
 128 ;;}}}
 129 ;;{{{ setup: -- vars
 130
 131 ;;; ....................................................... &v-version ...
 132
 133 (defconst tinylibo-version
 134   (substring "$Revision: 2.39 $" 11 15)
 135   "Latest version number.")
 136
 137 (defconst tinylibo-version-id
 138   "$Id: tinylibo.el,v 2.39 2007/05/01 17:20:45 jaalto Exp $"
 139   "Latest modification time and version number.")
 140
 141 ;;; ----------------------------------------------------------------------
 142 ;;;
 143 (defun  tinylibo-version (&optional arg)
 144   "Show version information. ARG will instruct to print message to echo area."
 145   (interactive "P")
 146   (ti::package-version-info "tinylibo.el" arg))
 147
 148 ;;; ----------------------------------------------------------------------
 149 ;;;
 150 (defun  tinylibo-feedback ()
 151   "Submit suggestions, error corrections, impressions, anything..."
 152   (interactive)
 153   (ti::package-submit-feedback "tinylibo.el"))
 154
 155 ;;}}}
 156
 157 ;;; ########################################################### &funcs ###
 158
 159 ;;{{{ macros
 160
 161 ;;; .......................................................... &macros ...
 162
 163 ;;; ----------------------------------------------------------------------
 164 ;;;
 165 (defsubst ti::overlay-make (level)
 166   "Make overlay according to match in buffer at LEVEL.
 167 The match is NOT checked. Returns new overlay."
 168   (make-overlay
 169    (match-beginning level)
 170    (match-end level)))
 171
 172 ;;; ----------------------------------------------------------------------
 173 ;;;
 174 (defsubst ti::overlay-makec (level)
 175   "Make overlay according to match in buffer at LEVEL.
 176 The match is checked. Returns new overlay or nil."
 177   (if (match-end level)
 178       (make-overlay
 179        (match-beginning level)
 180        (match-end level))))
 181
 182 ;;}}}
 183 ;;{{{ funcs
 184
 185 ;;; ----------------------------------------------------------------------
 186 ;;;
 187 (defun ti::overlay-make-match  (level plist)
 188   "Make overlay over the matched text portion. The match level is checked.
 189
 190 Input:
 191   LEVEL     match level
 192   PLIST     property list '(PRO-NAME PROP-VAL)
 193
 194 Return:
 195   ov        overlay or nil"
 196   (let* ((ov   (ti::overlay-makec level))
 197          prop
 198          propv)
 199     (when ov
 200       (while plist
 201         (setq prop (nth 0 plist)  propv (nth 1 plist))
 202         (setq plist (cdr (cdr plist)))  ;go 2 fwd
 203         (overlay-put ov prop propv)))
 204     ov))
 205
 206 ;;; ----------------------------------------------------------------------
 207 ;;;
 208 (defsubst ti::overlay-buffer-substring (ov &optional no-properties)
 209   "Read `buffer-substring' underneath overlay OV.
 210
 211 Input:
 212
 213   OV                    overlay, can also be nil.
 214   NO-PROPERTIES         flag, if non-nil remove all properties
 215
 216 Return:
 217
 218   string
 219   nil"
 220   (when ov
 221     (if no-properties
 222         (buffer-substring-no-properties (overlay-start ov) (overlay-end ov))
 223       (buffer-substring  (overlay-start ov) (overlay-end ov)))))
 224
 225 ;;; ----------------------------------------------------------------------
 226 ;;;
 227 (defun ti::overlay-mouse-on-p (ov)
 228   "Check if overlay OV has `mouse-face' on.
 229 If `mouse-face' contains 'default, it's treated to mean same as nil.
 230
 231 Return:
 232   nil or property value of `mouse-face'"
 233   (let* (prop
 234          propl)
 235     (when ov
 236       (setq propl (overlay-properties ov)
 237             prop  (when (memq 'mouse-face propl)
 238                     (overlay-get ov 'mouse-face)))
 239       (unless (or (null prop)
 240                   (eq prop 'default))
 241         ;;  it had some property
 242         prop))))
 243
 244 ;;; ----------------------------------------------------------------------
 245 ;;;
 246 (defun ti::overlay-get-mouse ()
 247   "Check if the point has 'mouse-face overlay.
 248
 249 Return:
 250
 251   nil          no overlay at the point found
 252   t            no mouse face
 253   ov           overlay"
 254   (let* (ovl                            ;overlay list
 255          ov)
 256     (when (setq ovl (overlays-at (point)))
 257       (setq ov (ti::overlay-get-prop ovl (list 'mouse-face)))
 258       (if (null ov)
 259           (setq ov t)))                 ;no mouse
 260     ov))
 261
 262 ;; ----------------------------------------------------------------------
 263 ;; 'prop'   means parameter form
 264 ;; - There should only one unique...
 265 ;;
 266 (defun ti::overlay-get-prop (ovl prop-list)
 267   "Read OVL and return first overlay where is property list PROP-LIST.
 268
 269 Input:
 270
 271   OVL           overlay list
 272   PROP-LIST     list of properties (PROP PROP ..)"
 273   (let ((len (length prop-list))
 274         ov
 275         ovx
 276         propl
 277         i)
 278     (unless (and ovl  prop-list)
 279       (error "Invalid parameters"))
 280
 281     (while (and ovl                     ;until list end
 282                 (null ov))              ;until found
 283       (setq ovx   (car ovl)
 284             propl (overlay-properties ovx)
 285             i     0)
 286
 287       (dolist (elt prop-list)           ;check all properties
 288         (when (memq elt propl)
 289           (incf  i)))                   ;hit counter
 290
 291       (if (eq i len)
 292           (setq ov ovx))                ;found all matches
 293       (setq ovl (cdr ovl)))
 294     ov))
 295
 296 ;; ----------------------------------------------------------------------
 297 ;; 'prop-val'   means parameter form
 298 ;; - This is more heavier function
 299 ;;
 300 (defun ti::overlay-get-prop-val (ovl prop-list)
 301   "Read OVL and find overlay(s) which contain PROP-LIST '(PROP VAL PROP VAL..)
 302
 303 Input:
 304
 305   OVL           overlay list
 306   PROP-LIST     list of properties (PROP VAL PROP VAL ..)"
 307   (let (len
 308         ov
 309         ovx
 310         ptr
 311         propl
 312         prop
 313         propv)
 314     (when ovl
 315       (setq len (length prop-list))
 316
 317       (if (or (not (and ovl prop-list))
 318               (not (= 0 (% len 2))))    ;must go paired
 319           (error "Invalid parameters" ovl prop-list)
 320
 321         (setq len (/ (length prop-list) 2))
 322
 323         ;; ..................................................... check ...
 324
 325         (while (and (setq ovx (pop ovl)) ;until list end
 326                     (null ov))           ;until found
 327
 328           (setq ptr   prop-list
 329                 propl (overlay-properties ovx))
 330
 331           (while ptr
 332             (setq prop  (car ptr)   ptr (cdr ptr)
 333                   propv (car ptr)   ptr (cdr ptr))
 334
 335 ;;;       (ti::d!! '!! prop propv
 336 ;;;            'memq (memq prop propl)
 337 ;;;            'get (overlay-get ovx prop) propv propl "\n")
 338
 339             (if (and (memq prop propl)
 340                      (equal (overlay-get ovx prop) propv))
 341                 (push ovx ov)))
 342
 343           (setq ovl (cdr ovl)))) ;; while-if
 344
 345 ;;;    (ti::d!! "~out" (prin1-to-string ov))
 346       ov)))
 347
 348 ;;; ----------------------------------------------------------------------
 349 ;;;
 350 (defun ti::overlay-re-search
 351   (re level list &optional max back reuse reuse-t no-prop-l)
 352   "Search for RE at LEVEL by creating overlay and its property LIST.
 353 Assigning LIST (PROP PROP_VAL) to the overlay. The search is repeated
 354 until no more hits or up till MAX point is reached.
 355
 356 Input:
 357
 358   RE    regexp
 359   LEVEL subexpression level in regexp
 360   LIST  list of (PROP PROP_VAL)
 361   MAX   if non-nil, searches up till MAX point.
 362   BACK  search backward
 363   REUSE (PROP PROP PROP ..) or (PROP_SYM PROP_VAL ..)
 364
 365         When re match is found it looks overlays underneath the
 366         point, and the first overlay that satisfies list, will
 367         be reused, instead of creating new one. Note that _first_
 368         overlay matched is used, if none is found, new is created
 369
 370   REUSE-T
 371
 372         Specifies the list _type_ that was given in REUSE.
 373         nil = first type , non-nil = second type.
 374
 375   NO-PROP-L
 376
 377         Ig given, then possible overlay starting at the same point must
 378         not have properties PROP-L (PROL VAL PROP VAL ..). If there is
 379         susch matching overlay, then do not create overlay.
 380
 381 Return:
 382
 383   nil                          nothing created or used.
 384   '(used-list created-list)    two lists, list of used and created overlays."
 385   (let* ((func (if back 're-search-backward 're-search-forward))
 386          (max  (if max
 387                    max                  ;it's given
 388                  (if back
 389                      (point-min)
 390                    (point-max))))
 391          ret-reused
 392          ret-created
 393          ov
 394          ovl
 395          prop
 396          propv
 397          ptr
 398          ;; match pointers
 399          mb)
 400     (unless (and list
 401                  (listp list)
 402                  (zerop (% (length list ) 2)))
 403       (error "Parameter LIST invalid" re level list))
 404
 405     (save-excursion
 406       (while (funcall func re max t)
 407         (setq mb  (match-beginning level))
 408
 409 ;;;     (ti::d! level (match-string level) mb)
 410
 411         (when mb                        ;match on this level found
 412
 413           ;; ....................................... find or create ov ...
 414
 415           (setq ovl (overlays-at mb))   ;try finding all overlays
 416
 417           (cond
 418            ((and ovl
 419                  (ti::overlay-get-prop-val ovl no-prop-l))
 420             ;; Do nothing, overlap happened
 421             nil)
 422
 423            ((or (null reuse)
 424                 (null ovl))
 425             (setq ov (ti::overlay-make level))
 426             (push ov ret-created ))
 427
 428            (t
 429 ;;;         (ti::d! "r" reuse ovl)  (setq OVL ovl RE reuse)
 430             (if reuse-t                 ;what type the list is ?
 431                 (if ovl
 432                     (setq ov (car-safe (ti::overlay-get-prop-val ovl reuse))))
 433               (if ovl
 434                   (setq ov (ti::overlay-get-prop ovl reuse))))
 435
 436 ;;;         (ti::d! "after" ov)
 437
 438             (if ov
 439                 (push ov ret-reused)
 440               (setq ov (ti::overlay-make level)) ;none satisfies us
 441               (push ov ret-created))))           ;; cond
 442
 443           ;; .................................... add properties to ov ...
 444           ;; Now we should have overlay in a way or other
 445
 446           (when ov
 447             (setq ptr list)
 448 ;;;       (ti::d! list)
 449             (while ptr
 450               (setq prop (nth 0 ptr)  propv (nth 1 ptr))
 451               (setq ptr (cdr (cdr ptr))) ;go 2 fwd
 452 ;;;         (ti::d! "put" prop propv ov)
 453               (overlay-put ov prop propv))))))
 454
 455     (when (or ret-reused ret-created)
 456       (list ret-reused ret-created))))
 457
 458 ;;; ----------------------------------------------------------------------
 459 ;;; Try following example:
 460 ;;;
 461 ;;; (setq OV (make-overlay (point) (point)))
 462 ;;; (overlay-put OV 'face 'highlight)
 463 ;;; (ti::overlay-re-search-move OV "ti::o")
 464 ;;;
 465 ;;;
 466 (defun ti::overlay-re-search-move (ov re &optional level back max)
 467   "Maove OV to Search forward for match RE at LEVEL.
 468 Default level is 0, full match. if BACK is given, search is done
 469 backward. MAX is last position to search.
 470
 471 If overlay OV is currently in some other buffer, it will be transferred
 472 to the current buffer.
 473
 474 Input:
 475
 476   OV    overlay
 477   RE    regexp
 478   LEVEL subexpression level in regexp
 479   BACK  flag, is non-nil, go backward
 480   MAX   max point of search
 481
 482 Return:
 483
 484   nil   if not moved.
 485   nbr   overlay end position [matched portion end]"
 486   (let* ((max       (or max
 487                         (if back (point-min) (point-max))))
 488          (level     (or level 0)))      ;default is full string
 489     (unless ov
 490       (error "invalid overlay, nil"))
 491
 492     (when (and (if back
 493                    (re-search-backward re max t)
 494                  (re-search-forward re max t))
 495                (match-end level))
 496       (move-overlay ov
 497                     (match-beginning level)
 498                     (match-end level)
 499                     (current-buffer))
 500       (match-end level))))
 501
 502 ;;; ----------------------------------------------------------------------
 503 ;;;
 504 (defun ti::overlay-get-within-area (propl &optional propl-t beg end)
 505   "Return all overlays which match property list PROPL.
 506 If PROPL is t then returns all overlays. Default is to search from
 507 current point forward.
 508
 509 Input:
 510   PROPL         property list, see next
 511   PROPL-T       if nil the propl is of type    (PROP PROP .. )
 512                 if non-nil                     (PROP VAL PROP VAL ..)
 513   BEG           region beginning
 514   END           region end"
 515   (let* ((p   (or beg (point)))
 516          (max (or end (point-max)))
 517          (all (eq t propl))
 518          ovl
 519          ovx
 520          list)
 521     (save-excursion
 522       (while (< p max)
 523         (goto-char p)
 524         (setq ovl (overlays-at p))
 525         (when ovl
 526           (if all
 527               (setq list (append ovl list))
 528             (if propl-t
 529                 (setq ovx (car-safe (ti::overlay-get-prop-val ovl propl)))
 530               (setq ovx (ti::overlay-get-prop ovl propl)))
 531             (if ovx
 532                 (push ovx list))))
 533         (setq p (next-overlay-change p))))
 534     list))
 535
 536 ;;; ----------------------------------------------------------------------
 537 ;;; If you're in trouble, call this function interactively
 538 ;;; and it wipes out all overlays.
 539 ;;;
 540 (defun ti::overlay-remove-region (&optional beg end propl propl-t)
 541   "Remove all matched overlays within area.
 542 Default is from point forward. Ignores buffer read-only status.
 543
 544 Input:
 545
 546   BEG        region beginning
 547   END        region end
 548   PROPL      (PROP PROP ..) or
 549              (PROP VAL PROP VAL ..)
 550              If this value is t, removes all overlays
 551
 552   PROPL-T   Specifies the list type given. nil = first list type."
 553   (interactive "r")
 554   (let* (buffer-read-only
 555          (p     (or beg (point)))
 556          (max   (or end (point-max)))
 557          (propl (if propl
 558                     propl
 559                   t))                   ;set to t is not given
 560          (ovl   (ti::overlay-get-within-area propl propl-t p max))
 561          ovx)
 562     (dolist (overlay ovl)
 563       (delete-overlay overlay))))
 564
 565 ;;}}}
 566
 567 (provide 'tinylibo)
 568
 569 ;;; tinylibo.el ends here