emacs/lisp/emacs-lisp/text-property-search.el

;;; text-property-search.el --- search for text properties  -*- lexical-binding:t -*-

;; Copyright (C) 2018-2020 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: convenience

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl-lib))

(cl-defstruct (prop-match)
  beginning end value)

(defun text-property-search-forward (property &optional value predicate
                                              not-current)
  "Search for the next region of text whose PROPERTY matches VALUE.

If not found, return nil and don't move point.
If found, move point to end of the region and return a `prop-match'
object describing the match.  To access the details of the match,
use `prop-match-beginning' and `prop-match-end' for the buffer
positions that limit the region, and `prop-match-value' for the
value of PROPERTY in the region.

PREDICATE is used to decide whether a value of PROPERTY should be
considered as matching VALUE.
If PREDICATE is t, that means a value must `equal' VALUE to be
considered a match.
If PREDICATE is nil, a value will match if it is non-nil and
is NOT `equal' to VALUE.
If PREDICATE is a function, it will be called with two arguments:
VALUE and the value of PROPERTY.  The function should return
non-nil if these two values are to be considered a match.

If NOT-CURRENT is non-nil, the function will search for the first
region that doesn't include point and has a value of PROPERTY
that matches VALUE."
  (interactive
   (list
    (let ((string (completing-read "Search for property: " obarray)))
      (when (> (length string) 0)
        (intern string obarray)))))
  (cond
   ;; No matches at the end of the buffer.
   ((eobp)
    nil)
   ;; We're standing in the property we're looking for, so find the
   ;; end.
   ((and (text-property--match-p value (get-text-property (point) property)
                                 predicate)
         (not not-current))
    (text-property--find-end-forward (point) property value predicate))
   (t
    (let ((origin (point))
          (ended nil)
          pos)
      ;; Find the next candidate.
      (while (not ended)
        (setq pos (next-single-property-change (point) property))
        (if (not pos)
            (progn
              (goto-char origin)
              (setq ended t))
          (goto-char pos)
          (if (text-property--match-p value (get-text-property (point) property)
                                      predicate)
              (setq ended
                    (text-property--find-end-forward
                     (point) property value predicate))
            ;; Skip past this section of non-matches.
            (setq pos (next-single-property-change (point) property))
            (unless pos
              (goto-char origin)
              (setq ended t)))))
      (and (not (eq ended t))
           ended)))))

(defun text-property--find-end-forward (start property value predicate)
  (let (end)
    (if (and value
             (null predicate))
        ;; This is the normal case: We're looking for areas where the
        ;; values aren't, so we aren't interested in sub-areas where the
        ;; property has different values, all non-matching value.
        (let ((ended nil))
          (while (not ended)
            (setq end (next-single-property-change (point) property))
            (if (not end)
                (progn
                  (goto-char (point-max))
                  (setq end (point)
                        ended t))
              (goto-char end)
              (unless (text-property--match-p
                       value (get-text-property (point) property) predicate)
                (setq ended t)))))
      ;; End this at the first place the property changes value.
      (setq end (next-single-property-change (point) property nil (point-max)))
      (goto-char end))
    (make-prop-match :beginning start
                     :end end
                     :value (get-text-property start property))))


(defun text-property-search-backward (property &optional value predicate
                                               not-current)
  "Search for the previous region of text whose PROPERTY matches VALUE.

Like `text-property-search-forward', which see, but searches backward,
and if a matching region is found, moves point to its beginning."
  (interactive
   (list
    (let ((string (completing-read "Search for property: " obarray)))
      (when (> (length string) 0)
        (intern string obarray)))))
  (cond
   ;; We're at the start of the buffer; no previous matches.
   ((bobp)
    nil)
   ;; We're standing in the property we're looking for, so find the
   ;; end.
   ((and (text-property--match-p
          value (get-text-property (1- (point)) property)
          predicate)
         (not not-current))
    (text-property--find-end-backward (1- (point)) property value predicate))
   (t
    (let ((origin (point))
          (ended nil)
          pos)
      (forward-char -1)
      ;; Find the previous candidate.
      (while (not ended)
        (setq pos (previous-single-property-change (point) property))
        (if (not pos)
            (progn
              (goto-char origin)
              (setq ended t))
          (goto-char (1- pos))
          (if (text-property--match-p value (get-text-property (point) property)
                                      predicate)
              (setq ended
                    (text-property--find-end-backward
                     (point) property value predicate))
            ;; Skip past this section of non-matches.
            (setq pos (previous-single-property-change (point) property))
            (unless pos
              (goto-char origin)
              (setq ended t)))))
      (and (not (eq ended t))
           ended)))))

(defun text-property--find-end-backward (start property value predicate)
  (let (end)
    (if (and value
             (null predicate))
        ;; This is the normal case: We're looking for areas where the
        ;; values aren't, so we aren't interested in sub-areas where the
        ;; property has different values, all non-matching value.
        (let ((ended nil))
          (while (not ended)
            (setq end (previous-single-property-change (point) property))
            (if (not end)
                (progn
                  (goto-char (point-min))
                  (setq end (point)
                        ended t))
              (goto-char (1- end))
              (unless (text-property--match-p
                       value (get-text-property (point) property) predicate)
                (goto-char end)
                (setq ended t)))))
      ;; End this at the first place the property changes value.
      (setq end (previous-single-property-change
                 (point) property nil (point-min)))
      (goto-char end))
    (make-prop-match :beginning end
                     :end (1+ start)
                     :value (get-text-property end property))))

(defun text-property--match-p (value prop-value predicate)
  (cond
   ((eq predicate t)
    (setq predicate #'equal))
   ((eq predicate nil)
    (setq predicate (lambda (val p-val)
                      (not (equal val p-val))))))
  (funcall predicate value prop-value))

(provide 'text-property-search)