emacs_el/tiny-tools/tiny/tinylibt.el

   1 ;;; tinylibt.el --- Library for handling text properties.
   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 tinylibt-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 tqhe 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 ;; ....................................................... &t-install ...
  38 ;; Put this file on your Emacs-Lisp load path, add following into
  39 ;; ~/.emacs startup file.
  40 ;;
  41 ;;  (require 'tinylibt)
  42 ;;
  43 ;; No autoload is suggested, because almost every function would have
  44 ;; to be in autoload state. It's easier to use require. Here are
  45 ;; suggested keybings for interactive use.
  46 ;;
  47 ;;  (global-unset-key "\C-z")
  48 ;;  (global-set-key "\C-ztm" 'ti::text-mark-region)   ;; e.g. permanent 'mark'
  49 ;;  (global-set-key "\C-ztu" 'ti::text-unmark-region) ;; remove 'mark'
  50 ;;  (global-set-key "\C-ztc" 'ti::text-clear-buffer-properties)
  51 ;;  (global-set-key "\C-ztb" 'ti::text-buffer)
  52 ;;  (global-set-key "\C-ztU" 'ti::text-undo)
  53 ;;
  54 ;; If you have any questions or feedback, use this function
  55 ;;
  56 ;;      M-x ti::text-submit-bug-report
  57
  58 ;;}}}
  59 ;;{{{ Documentation
  60
  61 ;; ..................................................... &t-commentary ...
  62
  63 ;;; Commentary:
  64
  65 ;;  Overview of features
  66 ;;
  67 ;;      o   This package is primary aimed for programmers, but
  68 ;;          interactive users will also find handy functions.
  69 ;;      o   Show matched text with color in the buffer.
  70 ;;      o   This is *NOTHING* like `font-lock' or `lazy-lock'
  71 ;;          which are demand driven packages intended for certain major modes.
  72 ;;          Use this package to "manually" mark interesting things in
  73 ;;          any buffer.
  74 ;;      o   Examples: highlighting on/off tabs, Verifying PGP
  75 ;;          fingerprints against trusted key server list
  76 ;;      o   UNDO: adjustable stack size. Stack is cleared if
  77 ;;          stack limit reached (stack 'wraps')
  78 ;;
  79 ;;  User functions
  80 ;;
  81 ;;      Mostly this package is designed for programmers, who add
  82 ;;      some highlight commands in hooks. For quick text highlighting,
  83 ;;      you can use these interactive functions:
  84 ;;
  85 ;;          ti::text-looking-at
  86 ;;          ti::text-buffer              ;; Highlight in whole buffer area
  87 ;;          ti::text-re-search-forward
  88 ;;          ti::text-re-search-backward
  89 ;;          ti::text-undo
  90 ;;
  91 ;;          ti::text-clear-buffer-properties
  92 ;;          ti::text-clear-region-properties
  93 ;;
  94 ;;          ti::text-mark-region
  95 ;;          ti::text-unmark-region
  96 ;;
  97 ;;          ti::text-mouse-mark-region
  98 ;;          ti::text-mouse-unmark-region
  99 ;;
 100 ;;  Setting different face (programming)
 101 ;;
 102 ;;      If you want permanetly change the face, when marking text
 103 ;;      use commands
 104 ;;
 105 ;;          ti::text-search-face-set   ;to set
 106 ;;          ti::text-search-face-reset ;to get default color back
 107 ;;
 108 ;;      If you want temporarily use some face, supply direct FACE parameter
 109 ;;      when you call search functions, like:
 110 ;;
 111 ;;          ti::text-re-search-forward (re &optional level face)
 112 ;;
 113 ;;  Note
 114 ;;
 115 ;;      This is for simple text highlighting only. Like finding certain items
 116 ;;      or marking something quickly and temporarily (great for text files)
 117 ;;
 118 ;;      You can mix font-lock/hilit19 and TIMA package, but remember that
 119 ;;      these packages have different goals. Use TIMA only for finding
 120 ;;      things in buffer, or marking certain articles in gnus...
 121 ;;
 122 ;;      Be carefull: if you use `ti::text-clear-buffer-properties', you will
 123 ;;      wipe out all text properties.
 124 ;;
 125 ;;  Example: highlighting tabs
 126 ;;
 127 ;;          (global-set-key "\C-ct" 'my-tabs-highligh-in-buffer)
 128 ;;
 129 ;;          (defun my-tabs-highligh-in-buffer (&optional arg)
 130 ;;            "Toggless hilit/dehiliting tabs in buffer.
 131 ;;          If ARG is integer, force highlighting. If ARG is C-u, then
 132 ;;          force dehighlighting."
 133 ;;            (interactive "P")
 134 ;;            (let (prop)
 135 ;;              (save-excursion
 136 ;;                (ti::pmin)
 137 ;;                (when (re-search-forward "\t" nil t)
 138 ;;               ;; is the tab marked?
 139 ;;               (setq prop (get-text-property (1- (point)) 'face))
 140 ;;               (cond
 141 ;;                ((or (integerp arg)             ;; Do highlighting
 142 ;;                     (or (eq prop nil)
 143 ;;                         (eq prop 'default)))
 144 ;;                 (beginning-of-line)
 145 ;;                 (ti::text-re-search-forward "\t+"))
 146 ;;                (t
 147 ;;                 (beginning-of-line)
 148 ;;                 ;; Remove
 149 ;;                 (ti::text-re-search-forward "\t+" 0 'default )))))))
 150 ;;
 151 ;;  Example: finding PGP key matches
 152 ;;
 153 ;;          (defun my-pgp-fp-certify  ()
 154 ;;            "To certify keys, E.g. get list of remailers
 155 ;;             from http://www.uit.no/
 156 ;;          - Display in window1 the UIT.NO result file
 157 ;;          - Put received key fingerprints in other window (pgp -ka
 158 ;;            will tell you)
 159 ;;
 160 ;;          Call this function in the Received keys buffer, and it'll
 161 ;;          highlight keys that match Fingerprint in uit.no window."
 162 ;;            (interactive)
 163 ;;            (let* ((blist  (ti::window-list 'buffers))
 164 ;;                   (buffer (car (delq (current-buffer) blist)))
 165 ;;                   A
 166 ;;                   elt
 167 ;;                   ok)
 168 ;;              (ti::pmin)
 169 ;;              (while (re-search-forward
 170 ;;                       "Key fingerprint.*= +\\(.*\\)" nil t)
 171 ;;                (setq elt (match-string 1)  ok nil)
 172 ;;                (setq A elt)
 173 ;;                (save-excursion
 174 ;;               (set-buffer buffer)
 175 ;;               (ti::pmin)
 176 ;;               (setq ok (ti::text-re-search-forward elt)))
 177 ;;                (when ok
 178 ;;               (beginning-of-line)
 179 ;;               (ti::text-looking-at ".*"))
 180 ;;                (end-of-line))))
 181 ;;
 182
 183 ;;}}}
 184
 185 ;;; Change Log:
 186
 187 ;;; Code:
 188
 189 ;;{{{ setup: require
 190
 191 ;;; ......................................................... &require ...
 192
 193 (require 'tinylibm)
 194 (eval-when-compile (ti::package-use-dynamic-compilation))
 195
 196 (ti::package-defgroup-tiny TinylibText ti::text-: extensions
 197   "Mark matched text in buffer with face.
 198   Overview of features
 199
 200         o   This package is primary aimed for elisp programmers, but
 201             interactive users will also find handy functions.
 202         o   Shows matched text with color in the buffer.
 203         o   This is *NOTHING* like font-lock, lazy-lock or hilit19,
 204             which are demand driven packages intended for certain major modes.
 205             Use this package to manually mark interesting things in
 206             any buffer.
 207         o   Examples: highlighting on/off tabs, Verifying PGP
 208             fingerprints against trusted list like http://www.uit.no/
 209         o   UNDO: adjustable stack size. Stack is cleared if
 210             stack limit reached (stack 'wraps')
 211     ")
 212
 213 ;;}}}
 214 ;;{{{ setup: variables
 215
 216 ;;; ......................................................... &v-hooks ...
 217
 218 (defcustom ti::text-:load-hook nil
 219   "*Hook run when file has been loaded."
 220   :type 'hook
 221   :group 'TinylibText)
 222
 223 (defcustom ti::text-:stack-size 1000
 224   "*How big undo history."
 225   :type 'number
 226   :group 'TinylibText)
 227
 228 ;;; ....................................................... &v-private ...
 229
 230 (defvar ti::text-:stack-count nil
 231   "Incremented after every search. Do not touch.")
 232
 233 (defvar ti::text-:stack-push-flag nil
 234   "Non-nil  means ('undo-func) do not record match data to stack.
 235 If this variable has value 'undo-func then the next calls to
 236 `ti::text-re-search' won't record data to stack.")
 237
 238 (defvar ti::text-:stack nil
 239   "Private. Contain last search data.
 240 This is actually property list stack so that undo can be done.
 241
 242 Format:
 243
 244   '(start-point
 245     last-func
 246     last-re
 247     las-beg-point
 248     last-level
 249     last-mode)")
 250
 251 ;;; ........................................................ &v-public ...
 252 ;;; user configurable
 253
 254 (defcustom ti::text-:face-tab-search-default 'highlight
 255   "*Default face used when marking searched text."
 256   :type '(symbol :tag "Face symbol")
 257   :group 'TinylibText)
 258
 259 ;;; For now, only search face is used, but maybe in the future the others..
 260 ;;;
 261 (defcustom ti::text-:face-table
 262   (list
 263    (cons 'search 'highlight)
 264    (cons 'warn   (if (ti::emacs-p) 'region 'bold)) ;XE doesn't have 'region face
 265    (cons 'head    'bold))
 266   "*Faces used for marking text."
 267   :type '(repeat
 268           (list
 269            (symbol :tag "symbolic face name"
 270                    (symbol :tag "Face name"))))
 271   :group 'TinylibText)
 272
 273 ;;}}}
 274 ;;{{{ version
 275
 276 (eval-and-compile
 277   (ti::macrof-version-bug-report
 278    "tinylibt.el"
 279    "tinulibt"
 280    ti::text-:version-id
 281    "$Id: tinylibt.el,v 2.46 2007/05/06 23:15:20 jaalto Exp $"
 282    '(ti::text-:version-id
 283      ti::text-:load-hook
 284      ti::text-:stack-size
 285      ti::text-:stack-count
 286      ti::text-:stack-push-flag
 287      ti::text-:stack
 288      ti::text-:face-search-default
 289      ti::text-:face-table)))
 290
 291 ;;}}}
 292 ;;{{{ code: misc funcs
 293
 294 ;;; ----------------------------------------------------------------------
 295 ;;;
 296 (defmacro ti::text-search-face-reset ()
 297   "Reset used face to the default value.
 298 If you use many colours to highlight text. Remember to call this
 299 when you're finished."
 300   (list
 301    'setcdr (list 'assq ''search 'ti::text-:face-table)
 302    'ti::text-:face-search-default))
 303
 304 ;;; ----------------------------------------------------------------------
 305 ;;;
 306 (defmacro ti::text-search-face-set (face)
 307   "Change search colour to FACE."
 308   (list 'setcdr (list 'assq ''search 'ti::text-:face-table) face))
 309
 310 ;;; ----------------------------------------------------------------------
 311 ;;;
 312 (defmacro ti::text-face (face)
 313   "Return real face when logical FACE is given."
 314   ;;  This way the global variable does not float around the file
 315   (list 'cdr (list 'assoc face 'ti::text-:face-table)))
 316
 317 ;;; ----------------------------------------------------------------------
 318 ;;;
 319 (defsubst ti::text-stack-clear ()
 320   "Clear undo stack."
 321   (put 'ti::text-:stack 'definition-stack nil)
 322   (setq ti::text-:stack-count  0
 323         ti::text-:stack        nil))
 324
 325 ;;; ----------------------------------------------------------------------
 326 ;;;
 327 (defsubst ti::text-stack-length ()
 328   "Return undo stack length."
 329   (length (get 'ti::text-:stack 'definition-stack)))
 330
 331 ;;; ----------------------------------------------------------------------
 332 ;;;
 333 (defsubst ti::text-stack-full-p ()
 334   "Check if stack is full."
 335   (eq (ti::text-stack-length) (1+ ti::text-:stack-size)))
 336
 337 ;;; ----------------------------------------------------------------------
 338 ;;;
 339 (defsubst ti::text-stack-p ()
 340   "Check if there is data in undo stack. nil means that stack is empty."
 341   (or (get 'ti::text-:stack 'definition-stack)
 342       ;;  Make sure this is also zero because there is no data
 343       (progn (setq ti::text-:stack-count 0) nil)))
 344
 345 ;;; ----------------------------------------------------------------------
 346 ;;;
 347 (defun ti::text-save-data (re level func mode beg)
 348   "Save search values RE LEVEL FUNC MODE BEG for undo.
 349 If the stack is full, then Clear the stack before pushing to it."
 350   (or (integerp ti::text-:stack-count)
 351       (setq ti::text-:stack-count (ti::text-stack-length) ))
 352   (when (and (stringp re)
 353              (not (eq ti::text-:stack-push-flag 'undo-func)))
 354
 355     ;; The last entry in the stack is always nil, that's why
 356     ;; 1+.
 357     ;;
 358     ;; inital:      nil
 359     ;; 1st:         '(mil)              pushed last data; size 1
 360     ;; 2nd          '((..) nil)         pushed next, size 2
 361     ;;
 362     ;; As you can see there actually is only one real data;
 363     ;; the 1st push reads the current calues of ti::text-:stack
 364     ;; which is nil; because it was the last element that was poped
 365     (when (>= ti::text-:stack-count
 366               (1+ ti::text-:stack-size))
 367       (ti::text-stack-clear)
 368       (setq ti::text-:stack-count 0))
 369     (ti::push-definition 'ti::text-:stack)
 370     (setq ti::text-:stack
 371           (list
 372            func
 373            re
 374            beg
 375            level
 376            mode))
 377     (incf  ti::text-:stack-count)))
 378
 379 ;;; ----------------------------------------------------------------------
 380 ;;;
 381 (defun ti::text-undo ()
 382   "Undo last highlighting.
 383 `ti::text-:stack-push-flag' is set to 'undo-func while this function runs."
 384   (interactive)
 385   (let* ((ti::text-:stack-push-flag  'undo-func)
 386          (prev   ti::text-:stack)
 387          func
 388          beg
 389          re
 390          level
 391          mode)
 392     ;; - Hm The stack values are empty now, try to pop last saved values
 393     ;;   from stack.
 394     ;; - Actually there should be something in the variable is the stack is
 395     ;;   not empty and it is an erro condition is variable IS empty AND
 396     ;;   there is values in the stack! ... We'll we don't nag about that
 397     ;;   here. I just thought you should know about it.
 398     (unless  prev
 399       (decf ti::text-:stack-count)
 400       (ti::pop-definition 'ti::text-:stack)
 401       (setq prev ti::text-:stack)) ;Maybe this time there is something
 402     (if (not (and (ti::listp prev)
 403                   (nth 0 prev)))
 404         (progn
 405           (ti::text-stack-clear)
 406           (error "tinylibt: No more undo information in stack."))
 407       (setq func    (nth 0 prev)
 408             re      (nth 1 prev)
 409             beg     (nth 2 prev)
 410             level   (nth 3 prev)
 411             mode    (nth 4 prev))
 412       (decf ti::text-:stack-count)
 413       (save-excursion
 414         ;;  - What if user has narrowed the buffer
 415         ;;  - Or he has deleted text
 416         (or (ignore-errors (goto-char beg))
 417             (error "\
 418 There is no such search point in the buffer any more? %s" beg))
 419         (cond
 420          ((eq func 'looking-at)
 421           (ti::text-looking-at re level 'default))
 422          (t
 423           (ti::text-re-search
 424            re
 425            (if (eq func 're-search-backward)
 426                'back nil)
 427            level
 428            nil
 429            'default
 430            mode))))
 431       ;;  UNDO done; now get next undo information
 432       (ti::pop-definition 'ti::text-:stack))))
 433
 434 ;;; ----------------------------------------------------------------------
 435 ;;;
 436 (defun ti::text-clear-buffer-properties (&optional  propl)
 437   "Remove all properties from buffer that match property list PROPL.
 438
 439 Input:
 440   See function `ti::text-clear-region-properties'"
 441   (interactive)
 442   (ti::text-clear-region-properties (point-min) (point-max) propl)
 443   (when (interactive-p)
 444     (redraw-display)
 445     (message "Properties cleared")))
 446
 447 ;;; ----------------------------------------------------------------------
 448 ;;;
 449 (defun ti::text-clear-region-properties (beg end &optional propl)
 450   "Remove properties from BEG END. Affects read only buffers too.
 451
 452 Input:
 453
 454   PROPL  (PROP VAL PROP VAL ..) Property list to match.
 455          If nil, then remove all properties."
 456   (interactive "r")
 457   (let* (buffer-read-only               ;allow writing
 458          point
 459          prop
 460          val
 461          list
 462          read-list
 463          elt
 464          rprop                          ;read property name
 465          rval
 466          delete)                        ;flag
 467     (with-buffer-modified
 468       (if (null propl)
 469           (set-text-properties beg end nil)
 470         (ti::keep-lower-order beg end)
 471         (setq prop (nth 0 propl)  val (nth 1 propl))
 472         (while (and (> (point-max) beg)
 473                     ;;  The beg is advanced in loop
 474                     ;;
 475                     (<= beg end)
 476                     (setq point (text-property-any beg end prop val)))
 477           (setq read-list (text-properties-at point)
 478                 list      propl
 479                 delete    t)
 480           (while list
 481             (setq rprop (nth 0 list)
 482                   rval  (nth 1 list)
 483                   list  (cdr (cdr list))) ;go 2 forward
 484             ;;  The memq return the rest of list
 485             ;;
 486             ;;      '(owner me face highlight  do-it nil)
 487             ;;      (memq 'face)  --> '(face highlight  do-it nil)
 488             ;;
 489             ;;  So the (nth 1) gives the value 'highlight which we
 490             ;;  test.
 491             (if (or (null (setq elt (memq rprop read-list)))
 492                     (not (eq (nth 1 elt) rval)))
 493                 ;;  This doesn'tmatch, stop and cancel delete
 494                 (setq list nil  delete nil)))
 495           ;;  Character by character, this is bit slow...
 496           (when delete
 497             (set-text-properties point (1+ point) nil))
 498           ;;  Search again
 499           (setq beg (1+ point)))))))
 500
 501 ;;; ----------------------------------------------------------------------
 502 ;;;
 503 (defun ti::text-get-mouse-property ()
 504   "Check if the point has 'mouse-face text property.
 505 notice that if value read from point is nil,
 506 that means same as no `mouse-face' property exists.
 507
 508 Return:
 509
 510   nil          no property at point found
 511   prop         `mouse-face' property value"
 512   (let* ((prop  (text-properties-at (point))))
 513     (if (setq prop (memq 'mouse-face prop))
 514         (cdr prop))))                   ;return value, may be nil
 515
 516 ;;; ----------------------------------------------------------------------
 517 ;;;
 518 (defun ti::text-match-level (&optional level face-or-propl beg end)
 519   "Add to match LEVEL a FACE-OR-PROPL in region BEG END.
 520 If no match in that level, do nothing. Property `rear-nonsticky' is
 521 added to the end of match unless FACE-OR-PROPL contains it.
 522
 523 Input:
 524
 525   LEVEL             Defaults to 0
 526   FACE-OR-PROPL     Defaults to '(face highlight)
 527                     If symbol, must be face symbol.
 528                     Can also be property list '(PROP VAL PROP VAL ..))
 529
 530   BEG END           If given, then these are the are matched."
 531   (let ((add-flag   t))
 532     (setq beg (or beg (match-beginning (or level 0)))
 533           end (or end (match-end       (or level 0))))
 534     (when (and (and beg end)
 535                (not (eq beg end)))      ;Nothing to do
 536       (cond
 537        ((null face-or-propl)
 538         (add-text-properties beg end '(face highlight)))
 539        ((symbolp face-or-propl)
 540         (add-text-properties beg end (list 'face face-or-propl)))
 541        (t
 542         (setq add-flag (null (memq 'rear-nonsticky face-or-propl)))
 543         (add-text-properties beg end face-or-propl)))
 544       (when add-flag
 545         (if (eq end 1) (setq end 2))    ;(1- 1) = 0, invalid charpos
 546         (add-text-properties (1- end) end '(rear-nonsticky t))))))
 547
 548 ;;; ----------------------------------------------------------------------
 549 ;;;
 550 ;;;###autoload
 551 (defun ti::text-re-search
 552   (re &optional direction level maxp face mode save-undo)
 553   "Highlight found text with search face.
 554
 555 Note:
 556
 557     The beginning of match and end of match will have
 558     property 'rear-nonsticky t, so that adding characters before of after
 559     text, won't inherit the face.
 560
 561 Input:
 562
 563   RE            str  regexp
 564   DIRECTION     bool non-nil means backward
 565   LEVEL         nbr  which subexpression in re to highlight, default is 0
 566   MAXP          nbr  last search point [default until bob/eob]
 567
 568   FACE          sym  face symbol
 569                      if symbol is 'null then set face to value nil
 570                      or if this is list; then it must be properly list
 571                      of format '(PROP PROP-VAL  PROP PROP-VAL ..)
 572
 573   MODE          nbr  signify that function should highlight all matches
 574                      that occur within LEVEL..NBR
 575                      if you have lot's of xx(match)yy|zz(match)tt|
 576                      the subexpression are counted from left to to
 577                      right: 1,2 ...
 578   SAVE-UNDO     flag non-nil means that the highlight information is
 579                      recorded for undo. This flag in on if function is
 580                      called interactively. NOTE: the undo information is
 581                      saved only if something was matched.
 582
 583 Return:
 584
 585  nil            No match
 586  nbr            start of match at LEVEL."
 587   (let* ((func          (if direction
 588                             're-search-backward
 589                           're-search-forward))
 590          (start-point   (point))
 591          buffer-read-only
 592          max-level
 593          count
 594          bp ep                          ;beg/end points
 595          ret
 596          prop
 597          val
 598          list)
 599     (with-buffer-modified
 600       ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. set defaults . .
 601       (or level
 602           (setq level 0))
 603       (or maxp
 604           (setq maxp
 605                 (if direction
 606                     (point-min)
 607                   (point-max))))
 608       (cond
 609        ((equal 'null face)
 610         (setq face nil))
 611        ((null face)
 612         (setq face (ti::text-face 'search))))
 613       ;;  Otherwise face is non-nil
 614       (setq max-level (1+ (or mode level)))
 615       ;; Make sure the property list has paired values if supplied
 616       (if (and (ti::listp face)
 617                (not (eq 0 (% (length face) 2))))
 618           (error "face properties are not paired: prop val"))
 619       ;; .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..  do matching . .
 620       (while (funcall func re maxp t)
 621         (setq count level)
 622         (while (< count max-level)
 623           (setq  bp (match-beginning count)
 624                  ep (match-end count))
 625           (if (and bp (null ret))       ;do only once
 626               (setq ret bp))
 627           (when (and bp (not (eq bp ep))) ;empty string
 628             (cond
 629              ((or (symbolp face)
 630                   (null face))
 631               (put-text-property bp ep 'face face))
 632              ((listp face)
 633               (setq list face)
 634               (while list
 635                 ;;  Read two values at time
 636                 ;;
 637                 (setq prop (car list) list (cdr list)
 638                       val  (car list) list (cdr list))
 639                 (put-text-property bp ep prop val))))
 640             ;;  #todo: something is wrong here, investigate..
 641             ;;
 642             ;;  If a character's `rear-nonsticky'
 643             ;;  property is `t', then none of its properties are rear-sticky.
 644             ;;
 645             ;;  Hmm, doesn't affect 19.28; is there bug in this emacs?
 646             ;;  The highlight is still extended If one adds chars after
 647             ;;  the matched text.
 648             ;;
 649             ;;  The stickiness must be activated ONE before the character.
 650             (let (beg)
 651               (if (eq bp (1- ep))
 652                   (setq beg (1- bp))
 653                 (setq beg (1- ep)))
 654               (if (zerop beg)
 655                   (setq beg 1))
 656               (add-text-properties beg ep '(rear-nonsticky t))))
 657           (setq count (1+ count))))
 658       ;;   Saving the search values for possible undo.
 659       (if (and save-undo ret)
 660           (ti::text-save-data re level func mode start-point))
 661       ;; Return success status
 662       ret)))
 663
 664 ;;; ----------------------------------------------------------------------
 665 ;;;
 666 (defun ti::text-property-search-and-modify
 667   (match-plist set-plist &optional beg end)
 668   "Search all characters forward, whose text properties match MATCH-PLIST.
 669 Set properties to SET-PLIST. The point moves along the search.
 670
 671 Input:
 672
 673  MATCH-PLIST    property list '(prop val prop val ..)
 674  SET-PLIST      property list '(prop val prop val ..)
 675  BEG            start point of search; defaults to `point-min'
 676  END            end point of search; defaults to `point-max'"
 677   (let* ((sprop (car match-plist))      ;serach property
 678          (sval  (car (cdr match-plist)))
 679          point
 680          plist mlist
 681          elt
 682          ok)
 683     (if (null match-plist)
 684         (error "Invalid match-plist"))
 685     (or beg (setq beg (point-min)))
 686     (or end (setq end (point-max)))
 687     (ti::keep-lower-order beg end)
 688     (goto-char beg)
 689     (setq point (1- (point)))
 690     (while (and (not (eobp))
 691                 (<= (point) end)
 692                 (setq point (text-property-any (1+ point) end sprop sval)))
 693       (goto-char point)
 694       (setq plist (text-properties-at (point))
 695             mlist match-plist
 696             ok t)
 697       (while (and ok mlist)
 698         ;; Select 1str PROP fro match-list and see if it is in read PLIST
 699         ;; Continue until all MLIST properties are found from read PLIST
 700         (setq elt (memq (car mlist) plist)
 701               ;;   first non-match terminates loop immediately
 702               ok    (and elt (eq (nth 1 elt) (nth 1 mlist)))
 703               mlist (cdr (cdr mlist))))
 704       (if ok
 705           (set-text-properties (point) (1+ (point)) set-plist)))))
 706
 707 ;;}}}
 708 ;;{{{ code: interactive
 709
 710 ;;; ----------------------------------------------------------------------
 711 ;;; Mon, 12 Feb 1996,  Tom Fontaine <fontaine@esd.ray.com>
 712 ;;; Sent this piece of code.  Thanks Tom!
 713 ;;;
 714 (defun ti::text-read-regexp ()
 715   "Read regexp using `regexp-history'."
 716   (let*
 717       ((default (car regexp-history))
 718        (input
 719         (read-from-minibuffer
 720          (if default
 721              (format "Highlight matching regexp (default `%s'): " default)
 722            "Highlight matching regexp: ")
 723          nil nil nil
 724          'regexp-history)))
 725     (if (> (length input) 0)            ;the return value
 726         input
 727       (setcar regexp-history default))))
 728
 729 ;;; ----------------------------------------------------------------------
 730 ;;;
 731 ;;;###autoload
 732 (defun ti::text-looking-at (re &optional level face-or-plist )
 733   "Highlight found RE at LEVEL with FACE-OR-PLIST.
 734 The LEVEL is subexpression to highlight. PLIST means property list."
 735   (interactive "slook at: ")
 736   (let (buffer-read-only)               ;allow writing
 737     (with-buffer-modified
 738       (setq level               (or level 0)
 739             face-or-plist (or face-or-plist (ti::text-face 'search)))
 740
 741       (when (and (looking-at re)
 742                  (match-end level))
 743         (ti::text-save-data re level 'looking-at nil (point))
 744         (ti::text-match-level level face-or-plist)))))
 745
 746 ;;; ----------------------------------------------------------------------
 747 ;;;
 748 ;;;###autoload
 749 (defun ti::text-buffer (re &optional level face mode save-undo)
 750   "Highlight RE and sub LEVEL in whole buffer, starting from `point-min'.
 751 Preserve point.
 752
 753 See `ti::text-re-search' for descriptions of FACE MODE and SAVE-UNDO."
 754   (interactive (list (ti::text-read-regexp)  current-prefix-arg))
 755   (save-excursion
 756     (if (interactive-p)
 757         (setq save-undo t))
 758     (goto-char (point-min))
 759     (ti::text-re-search re nil level nil face mode save-undo)))
 760
 761 ;;; ----------------------------------------------------------------------
 762 ;;;
 763 ;;;###autoload
 764 (defun ti::text-re-search-forward (re &optional level face mode save-undo)
 765   "Search RE and highlight forward until `point-max'.
 766 Optional prefix arg tells which subexpression LEVEL to match that
 767 function should highlight. point is preserved during call.
 768
 769 See `ti::text-re-search' for descriptions of FACE MODE SAVE-UNDO."
 770   (interactive (list (ti::text-read-regexp)  current-prefix-arg))
 771   (save-excursion
 772     (if (interactive-p)
 773         (setq save-undo t))
 774     (ti::text-re-search re nil level nil face mode save-undo)))
 775
 776 ;;; ----------------------------------------------------------------------
 777 ;;;
 778 ;;;###autoload
 779 (defun ti::text-re-search-backward (re &optional level face mode save-undo)
 780   "Search RE and highlight backward until `point-min'.
 781 Optional prefix arg tells which subexpression LEVEL to match that
 782 function should highlight. point is preserved during call.
 783
 784 See `ti::text-re-search' for descriptions of FACE MODE SAVE-UNDO."
 785   (interactive (list (ti::text-read-regexp)  current-prefix-arg))
 786   (save-excursion
 787     (if (interactive-p)
 788         (setq save-undo t))
 789     (ti::text-re-search re 'back level nil face mode save-undo)))
 790
 791 ;;; ----------------------------------------------------------------------
 792 ;;; - These are handy when you want to "mark" ceratin texts for quick ref.
 793 ;;;
 794 ;;;###autoload
 795 (defun ti::text-mouse-mark-region (beg end event)
 796   "Highlight region BEG END. EVENT is mouse event."
 797   (interactive "r\ne")
 798   (ti::text-mark-region beg end))
 799
 800 ;;; ----------------------------------------------------------------------
 801 ;;;
 802 ;;;###autoload
 803 (defun ti::text-mouse-unmark-region (beg end event)
 804   "Remove highlight from region BEG END. EVENT is mouse event."
 805   (interactive "r\ne")
 806   (ti::text-mark-region beg end 'remove))
 807
 808 ;;; - This is for keyboard users
 809 ;;;
 810 ;;;###autoload
 811 (defun ti::text-unmark-region (beg end)
 812   "Remove highlight from region BEG END."
 813   (interactive "r")
 814   (ti::text-mark-region beg end 'remove))
 815
 816 ;;; ----------------------------------------------------------------------
 817 ;;;
 818 ;;;###autoload
 819 (defun ti::text-mark-region (beg end &optional remove face)
 820   "Highlight BEG END. With optional prefix arg REMOVE all matching FACE."
 821   (interactive "r\nP")
 822   (let* (buffer-read-only               ;set this to nil
 823          (face      (if remove
 824                         'default
 825                       (or face (ti::text-face 'search)))))
 826     (with-buffer-modified
 827       (put-text-property beg end 'face face))))
 828
 829 ;;}}}
 830
 831 (provide     'tinylibt)
 832 (run-hooks   'ti::text-:load-hook)
 833
 834 ;;; tinylibt.el ends here