1032 lines
46 KiB
EmacsLisp
1032 lines
46 KiB
EmacsLisp
;;; tp-search.el --- Pattern matching and property search for tp -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2024-2026 Geekinney
|
|
|
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
|
|
|
;; This program 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.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Pattern-driven property application (`tp-match-*', `tp-regexp-*')
|
|
;; and property-run search/navigation (`tp-search', `tp-search-map',
|
|
;; `tp-forward', `tp-backward', `tp-forward-do', `tp-backward-do').
|
|
|
|
;;; Code:
|
|
|
|
(require 'cl-lib)
|
|
(require 'text-property-search)
|
|
(require 'tp-core)
|
|
(require 'tp-layer)
|
|
(require 'tp-ops)
|
|
|
|
(defconst tp-any-value (make-symbol "tp-any-value")
|
|
"Unique wildcard used by tp property-search APIs.
|
|
Omitting VALUE selects this sentinel automatically. Pass the variable
|
|
`tp-any-value' explicitly when a later positional argument is needed
|
|
and any present direct value should match. An explicit nil VALUE is
|
|
therefore available for exact, presence-aware nil matching.")
|
|
|
|
(defun tp--pattern-apply-single (pattern properties apply-fn object literal
|
|
&optional start end subexp)
|
|
"Apply PROPERTIES with APPLY-FN to matches of single PATTERN in OBJECT.
|
|
When LITERAL is non-nil, PATTERN is matched literally; otherwise it
|
|
is a regexp. APPLY-FN is called with (START END PROPS OBJECT) for
|
|
each match.
|
|
START and END restrict matching to the [START, END) portion of
|
|
OBJECT, in native coordinates (0-based for strings, 1-based for
|
|
buffers); nil means the object's bounds. If START > END the bounds
|
|
are swapped (matching the buffer path's historical `narrow-to-region'
|
|
behavior, now uniform across object types). Matching behaves as if
|
|
OBJECT consisted only of that portion (the buffer path narrows, the
|
|
string path matches against the substring), so no match crosses the
|
|
boundaries.
|
|
When SUBEXP is non-nil, it names a capture group of PATTERN: the
|
|
properties and returned regions cover (match-beginning SUBEXP) to
|
|
\(match-end SUBEXP) of each match, and a match in which that group
|
|
does not participate contributes nothing. The scan still advances
|
|
past the whole match. A SUBEXP larger than PATTERN's group count
|
|
\(per `regexp-opt-depth') signals an error instead of silently
|
|
matching nothing.
|
|
For strings, returns a NEW string with properties applied
|
|
\(non-destructive).
|
|
For buffers, modifies in-place and returns list of regions.
|
|
|
|
Zero-width matches (an empty literal pattern, or a regexp that can
|
|
match the empty string) are recorded and the scan advances one
|
|
position past them, so the search always terminates."
|
|
(let ((regexp (if literal (regexp-quote pattern) pattern)))
|
|
;; Reversed bounds are swapped, not signaled: the buffer path's
|
|
;; narrow-to-region always did this, so the string path follows.
|
|
(when (and start end (> start end))
|
|
(cl-rotatef start end))
|
|
;; A group number beyond the pattern's group count could never
|
|
;; match; make the typo loud instead of a silent no-op.
|
|
(when (and subexp (> subexp (regexp-opt-depth regexp)))
|
|
(error "Regexp %S has no group %d" pattern subexp))
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
;; First, collect all match positions from the original string.
|
|
;; Bounded searches run against the substring so matches cannot
|
|
;; cross the [START, END) boundaries; positions are shifted back
|
|
;; into whole-string coordinates afterwards.
|
|
(let* ((from (max (or start 0) 0))
|
|
(to (min (or end (length object)) (length object)))
|
|
(searchable (if (and (= from 0) (= to (length object)))
|
|
object
|
|
(substring object from to)))
|
|
(matches nil)
|
|
(pos 0)
|
|
(limit (- to from)))
|
|
(while (and (<= pos limit) (string-match regexp searchable pos))
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0))
|
|
(sub-beg (match-beginning (or subexp 0)))
|
|
(sub-end (match-end (or subexp 0))))
|
|
;; A group that does not participate contributes nothing.
|
|
(when sub-beg
|
|
(push (cons (+ from sub-beg) (+ from sub-end)) matches))
|
|
(setq pos (if (= beg end) (1+ beg) end))))
|
|
;; Apply function to each match in order (reverse to get correct order)
|
|
;; Make a copy to ensure original string is not modified
|
|
(let ((result (copy-sequence object)))
|
|
(dolist (match (nreverse matches))
|
|
(when properties
|
|
(setq result (funcall apply-fn
|
|
(car match) (cdr match)
|
|
properties result))))
|
|
result)))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((buf (or object (current-buffer))))
|
|
(tp-with-current-buffer buf
|
|
(save-excursion
|
|
(save-restriction
|
|
(when (or start end)
|
|
(narrow-to-region (max (or start (point-min)) (point-min))
|
|
(min (or end (point-max)) (point-max))))
|
|
(goto-char (point-min))
|
|
(let (regions (keep-going t))
|
|
(while (and keep-going (re-search-forward regexp nil t))
|
|
(let ((beg (match-beginning 0))
|
|
(end (match-end 0))
|
|
(sub-beg (match-beginning (or subexp 0)))
|
|
(sub-end (match-end (or subexp 0))))
|
|
;; A group that does not participate contributes nothing.
|
|
(when sub-beg
|
|
(when properties
|
|
(funcall apply-fn sub-beg sub-end properties buf))
|
|
(push (cons sub-beg sub-end) regions))
|
|
;; Guard against zero-width matches looping forever
|
|
(when (= beg end)
|
|
(if (eobp)
|
|
(setq keep-going nil)
|
|
(forward-char 1)))))
|
|
(nreverse regions))))))))))
|
|
|
|
(defun tp--pattern-apply (pattern properties apply-fn object literal
|
|
&optional start end subexp)
|
|
"Apply PROPERTIES with APPLY-FN to matches of PATTERN.
|
|
When LITERAL is non-nil, patterns are matched literally; otherwise
|
|
they are regexps. APPLY-FN is called with (START END PROPS OBJECT)
|
|
for each match.
|
|
START and END restrict matching to [START, END) in native
|
|
coordinates; SUBEXP names a capture group to target (see
|
|
`tp--pattern-apply-single').
|
|
For strings, returns a NEW string with properties applied
|
|
\(non-destructive).
|
|
For buffers, returns list of regions."
|
|
(let ((patterns (if (listp pattern) pattern (list pattern))))
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
(let ((result object))
|
|
(dolist (p patterns)
|
|
(setq result (tp--pattern-apply-single p properties apply-fn
|
|
result literal
|
|
start end subexp)))
|
|
result))
|
|
;; Buffer or nil (current buffer)
|
|
(t
|
|
(let ((all-regions nil))
|
|
(dolist (p patterns)
|
|
(let ((regions (tp--pattern-apply-single p properties apply-fn
|
|
object literal
|
|
start end subexp)))
|
|
(setq all-regions (append all-regions regions))))
|
|
all-regions)))))
|
|
|
|
(defun tp--match-apply-single (pattern properties apply-fn object
|
|
&optional start end)
|
|
"Apply PROPERTIES with APPLY-FN to literal matches of PATTERN in OBJECT.
|
|
START and END restrict matching to [START, END) in native coordinates.
|
|
For strings, returns a new string with properties applied (non-destructive).
|
|
For buffers, modifies in-place and returns list of regions."
|
|
(tp--pattern-apply-single pattern properties apply-fn object t start end))
|
|
|
|
(defun tp--match-apply (pattern properties apply-fn &optional object start end)
|
|
"Apply PROPERTIES with APPLY-FN to matches of PATTERN.
|
|
PATTERN can be a string or a list of strings (multiple patterns).
|
|
When PATTERN is a list, each element is a pattern to match.
|
|
APPLY-FN is called with (START END PROPS OBJECT) for each match.
|
|
START and END restrict matching to [START, END) in native coordinates.
|
|
For strings, returns a NEW string with properties applied (non-destructive).
|
|
For buffers, returns list of regions."
|
|
(tp--pattern-apply pattern properties apply-fn object t start end))
|
|
|
|
(defun tp--regexp-apply-single (pattern properties apply-fn object
|
|
&optional start end subexp)
|
|
"Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN in OBJECT.
|
|
APPLY-FN is called with (START END PROPS OBJECT) for each match.
|
|
START and END restrict matching to [START, END) in native
|
|
coordinates; SUBEXP names a capture group to target.
|
|
For strings, returns a NEW string with properties applied (non-destructive).
|
|
For buffers, modifies in-place and returns list of regions."
|
|
(tp--pattern-apply-single pattern properties apply-fn object nil
|
|
start end subexp))
|
|
|
|
(defun tp--regexp-apply (pattern properties apply-fn
|
|
&optional object start end subexp)
|
|
"Apply PROPERTIES with APPLY-FN to regexp matches of PATTERN.
|
|
PATTERN can be a string (single regexp) or a list of strings (multiple regexps).
|
|
When PATTERN is a list, each element is a regexp to match.
|
|
APPLY-FN is called with (START END PROPS OBJECT) for each match.
|
|
START and END restrict matching to [START, END) in native
|
|
coordinates; SUBEXP names a capture group to target.
|
|
For strings, returns a NEW string with properties applied (non-destructive).
|
|
For buffers, returns list of regions."
|
|
(tp--pattern-apply pattern properties apply-fn object nil start end subexp))
|
|
|
|
(defun tp-match-set (pattern plist &optional object start end)
|
|
"Set properties on all occurrences of PATTERN.
|
|
|
|
(tp-match-set PATTERN PLIST &optional OBJECT START END)
|
|
|
|
PATTERN is a string (single pattern) or list of strings (multiple patterns).
|
|
Each pattern will be matched and have properties applied.
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
START and END restrict matching to the [START, END) portion of
|
|
OBJECT, in native coordinates (0-based for strings, 1-based for
|
|
buffers); nil means the object's bounds. If START > END the bounds
|
|
are swapped. Matching behaves as if OBJECT consisted only of that
|
|
portion, so no match crosses the boundaries.
|
|
|
|
Returns:
|
|
- For strings: a NEW string with properties applied (the original
|
|
string is not modified)
|
|
- For buffers: list of (START . END) pairs for all matches."
|
|
(tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp-set object
|
|
start end))
|
|
|
|
(defun tp-match-reset (pattern plist &optional object start end)
|
|
"Reset (completely replace) properties on all occurrences of PATTERN.
|
|
|
|
(tp-match-reset PATTERN PLIST &optional OBJECT START END)
|
|
|
|
PATTERN is a string (single pattern) or list of strings (multiple patterns).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
START and END restrict matching to the [START, END) portion of
|
|
OBJECT, in native coordinates (0-based for strings, 1-based for
|
|
buffers); nil means the object's bounds. If START > END the bounds
|
|
are swapped.
|
|
|
|
Unlike `tp-match-set', this completely replaces all existing properties.
|
|
|
|
For strings, returns a NEW string (original is not modified).
|
|
For buffers, modifies in-place and returns list of (START . END)
|
|
regions."
|
|
(tp--match-apply pattern (tp--prepare-direct-properties plist)
|
|
#'tp--reset-apply
|
|
object start end))
|
|
|
|
(defun tp-match-add (pattern plist &optional object start end)
|
|
"Add/update properties on all occurrences of PATTERN.
|
|
|
|
(tp-match-add PATTERN PLIST &optional OBJECT START END)
|
|
|
|
PATTERN is a string (single pattern) or list of strings (multiple patterns).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
START and END restrict matching to the [START, END) portion of
|
|
OBJECT, in native coordinates (0-based for strings, 1-based for
|
|
buffers); nil means the object's bounds. If START > END the bounds
|
|
are swapped.
|
|
|
|
Unlike `tp-match-set', this deeply merges nested properties.
|
|
|
|
For strings, returns a NEW string (original is not modified).
|
|
For buffers, modifies in-place and returns list of (START . END)
|
|
regions."
|
|
(tp--match-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply
|
|
object start end))
|
|
|
|
(defun tp-regexp-set (pattern plist &optional object start end subexp)
|
|
"Set properties on all matches of PATTERN (regexp).
|
|
|
|
(tp-regexp-set PATTERN PLIST &optional OBJECT START END SUBEXP)
|
|
|
|
PATTERN is a string (single regexp) or list of strings (multiple regexps).
|
|
Each pattern will be matched and have properties applied.
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
START and END restrict matching to the [START, END) portion of
|
|
OBJECT, in native coordinates (0-based for strings, 1-based for
|
|
buffers); nil means the object's bounds. If START > END the bounds
|
|
are swapped. Matching behaves as if OBJECT consisted only of that
|
|
portion, so no match crosses the boundaries.
|
|
When SUBEXP is non-nil, it names a capture group of PATTERN (1 for
|
|
the first group, like font-lock highlights): properties apply to that
|
|
group of each match instead of the whole match, and a match in which
|
|
the group does not participate contributes nothing. A SUBEXP larger
|
|
than PATTERN's group count signals an error.
|
|
|
|
Returns:
|
|
- For strings: a NEW string with properties applied (the original
|
|
string is not modified)
|
|
- For buffers: list of (START . END) pairs for all matches."
|
|
(tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp-set object
|
|
start end subexp))
|
|
|
|
(defun tp-regexp-reset (pattern plist &optional object start end subexp)
|
|
"Reset (completely replace) properties on all regexp matches of PATTERN.
|
|
|
|
(tp-regexp-reset PATTERN PLIST &optional OBJECT START END SUBEXP)
|
|
|
|
PATTERN is a string (single regexp) or list of strings (multiple regexps).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
START and END restrict matching to the [START, END) portion of
|
|
OBJECT, in native coordinates (0-based for strings, 1-based for
|
|
buffers); nil means the object's bounds. If START > END the bounds
|
|
are swapped.
|
|
When SUBEXP is non-nil, properties apply to that capture group of
|
|
each match instead of the whole match; a match in which the group
|
|
does not participate contributes nothing. A SUBEXP larger than
|
|
PATTERN's group count signals an error.
|
|
|
|
Unlike `tp-regexp-set', this completely replaces all existing properties.
|
|
|
|
For strings, returns a NEW string (original is not modified).
|
|
For buffers, modifies in-place and returns list of (START . END)
|
|
regions."
|
|
(tp--regexp-apply pattern (tp--prepare-direct-properties plist)
|
|
#'tp--reset-apply
|
|
object start end subexp))
|
|
|
|
(defun tp-regexp-add (pattern plist &optional object start end subexp)
|
|
"Add/update properties on all regexp matches of PATTERN.
|
|
|
|
(tp-regexp-add PATTERN PLIST &optional OBJECT START END SUBEXP)
|
|
|
|
PATTERN is a string (single regexp) or list of strings (multiple regexps).
|
|
PLIST is a property list like \\='(face bold help-echo \"tip\"),
|
|
or a symbol representing a layer/group name defined by `define-tp'
|
|
or `define-tp-group'.
|
|
OBJECT is a buffer or string; nil means current buffer.
|
|
START and END restrict matching to the [START, END) portion of
|
|
OBJECT, in native coordinates (0-based for strings, 1-based for
|
|
buffers); nil means the object's bounds. If START > END the bounds
|
|
are swapped.
|
|
When SUBEXP is non-nil, properties apply to that capture group of
|
|
each match instead of the whole match; a match in which the group
|
|
does not participate contributes nothing. A SUBEXP larger than
|
|
PATTERN's group count signals an error.
|
|
|
|
Unlike `tp-regexp-set', this deeply merges nested properties.
|
|
|
|
For strings, returns a NEW string (original is not modified).
|
|
For buffers, modifies in-place and returns list of (START . END)
|
|
regions."
|
|
(tp--regexp-apply pattern (tp--prepare-direct-properties plist) #'tp--deep-merge-apply
|
|
object start end subexp))
|
|
|
|
(defun tp-search-forward (property &optional value predicate not-current)
|
|
"Search forward from point for text whose PROPERTY matches VALUE.
|
|
This is a raw wrapper: PROPERTY, VALUE, PREDICATE and NOT-CURRENT are
|
|
passed unchanged to `text-property-search-forward', whose semantics
|
|
apply in full - including the primitive's nil-PREDICATE default of
|
|
matching values that are non-nil and NOT `equal' to VALUE. On
|
|
success point moves to the end of the matched region and a prop-match
|
|
object is returned; otherwise nil.
|
|
|
|
Obsolete since tp 0.3.0: call `tp-forward' for tp's `equal'-matching
|
|
search (which also supports string OBJECTs and repeat counts), or
|
|
call the Emacs primitive `text-property-search-forward' directly for
|
|
raw use - this wrapper adds nothing to it."
|
|
(text-property-search-forward property value predicate not-current))
|
|
(make-obsolete 'tp-search-forward 'tp-forward "0.3.0")
|
|
|
|
(defun tp-search-backward (property &optional value predicate not-current)
|
|
"Search backward from point for text whose PROPERTY matches VALUE.
|
|
This is a raw wrapper: PROPERTY, VALUE, PREDICATE and NOT-CURRENT are
|
|
passed unchanged to `text-property-search-backward', whose semantics
|
|
apply in full - including the primitive's nil-PREDICATE default of
|
|
matching values that are non-nil and NOT `equal' to VALUE. On
|
|
success point moves to the beginning of the matched region and a
|
|
prop-match object is returned; otherwise nil.
|
|
|
|
Obsolete since tp 0.3.0: call `tp-backward' for tp's `equal'-matching
|
|
search (which also supports string OBJECTs and repeat counts), or
|
|
call the Emacs primitive `text-property-search-backward' directly for
|
|
raw use - this wrapper adds nothing to it."
|
|
(text-property-search-backward property value predicate not-current))
|
|
(make-obsolete 'tp-search-backward 'tp-backward "0.3.0")
|
|
|
|
(defun tp--property-match-p (value prop-value predicate)
|
|
"Return non-nil when PROP-VALUE matches VALUE under PREDICATE.
|
|
PREDICATE follows the convention tp uses for
|
|
`text-property-search-forward': nil and t both mean the values must
|
|
be `equal' (tp's 0.2.0 symmetric matching contract); a function is
|
|
called with VALUE and PROP-VALUE and matches when it returns
|
|
non-nil. `tp-any-value' matches every PROP-VALUE."
|
|
(if (functionp predicate)
|
|
(funcall predicate value prop-value)
|
|
(or (eq value tp-any-value)
|
|
(equal value prop-value))))
|
|
|
|
(defun tp--property-matches (object start end property value predicate)
|
|
"Collect direct PROPERTY matches in OBJECT between START and END.
|
|
Each result is a canonical `tp--match'. A run is eligible only when
|
|
PROPERTY is present in `text-properties-at', so an explicit nil value
|
|
is distinct from absence. Boundaries caused only by unrelated
|
|
properties are joined back into one PROPERTY run."
|
|
(let ((obj (or object (current-buffer)))
|
|
(pos start)
|
|
(results nil))
|
|
(while (< pos end)
|
|
(let* ((next (or (next-property-change pos object end) end))
|
|
(presence (tp--presence-at pos property object))
|
|
(prop-value (tp--presence-value presence)))
|
|
(when (and (tp--presence-present-p presence)
|
|
(tp--property-match-p value prop-value predicate))
|
|
(let ((previous (car results)))
|
|
(if (and previous
|
|
(= (tp--native-range-end
|
|
(tp--match-range previous))
|
|
pos)
|
|
(equal (tp--match-value previous) prop-value))
|
|
(setf (tp--native-range-end
|
|
(tp--match-range previous))
|
|
next)
|
|
(push (tp--make-match
|
|
(tp--make-native-range
|
|
obj (tp--object-kind obj) pos next)
|
|
property prop-value)
|
|
results))))
|
|
(setq pos next)))
|
|
(nreverse results)))
|
|
|
|
(defun tp--property-search-backward (property value
|
|
&optional predicate not-current)
|
|
"Search backward for the previous region where PROPERTY matches VALUE.
|
|
Only direct PROPERTY runs are candidates. VALUE and PREDICATE follow
|
|
`tp--property-match-p'. NOT-CURRENT skips the run containing point."
|
|
(unless (bobp)
|
|
(let* ((origin (point))
|
|
(matches (nreverse
|
|
(tp--property-matches
|
|
(current-buffer) (point-min) (point-max)
|
|
property value predicate)))
|
|
(found
|
|
(seq-find
|
|
(lambda (match)
|
|
(and (< (tp--native-range-start (tp--match-range match))
|
|
origin)
|
|
(not (and not-current
|
|
(<= (tp--native-range-start
|
|
(tp--match-range match))
|
|
origin)
|
|
(>= (tp--native-range-end
|
|
(tp--match-range match))
|
|
origin)))))
|
|
matches)))
|
|
(when found
|
|
(let ((range (tp--match-range found)))
|
|
(goto-char (tp--native-range-start range))
|
|
(setf (tp--native-range-end range)
|
|
(min origin (tp--native-range-end range)))
|
|
(tp--match-to-prop-match found))))))
|
|
|
|
(defun tp--property-search-forward (property value predicate not-current)
|
|
"Search forward for PROPERTY matching VALUE under PREDICATE.
|
|
When NOT-CURRENT is non-nil, skip the run containing point."
|
|
(let* ((origin (point))
|
|
(found
|
|
(seq-find
|
|
(lambda (match)
|
|
(and (> (tp--native-range-end (tp--match-range match))
|
|
origin)
|
|
(not (and not-current
|
|
(<= (tp--native-range-start
|
|
(tp--match-range match))
|
|
origin)
|
|
(< origin
|
|
(tp--native-range-end
|
|
(tp--match-range match)))))))
|
|
(tp--property-matches
|
|
(current-buffer) (point-min) (point-max)
|
|
property value predicate))))
|
|
(when found
|
|
(let ((range (tp--match-range found)))
|
|
(goto-char (tp--native-range-end range))
|
|
(setf (tp--native-range-start range)
|
|
(max origin (tp--native-range-start range)))
|
|
(tp--match-to-prop-match found)))))
|
|
|
|
(defun tp--search-result-value (object start end property value)
|
|
"Return matches for PROPERTY and VALUE in OBJECT between START and END."
|
|
(let* ((range (tp--native-range-from-object object start end))
|
|
(request (tp--make-request
|
|
:operation :search :range range :property property
|
|
:value value :public-return :matches))
|
|
(matches (tp--property-matches
|
|
(tp--native-range-object range)
|
|
(tp--native-range-start range)
|
|
(tp--native-range-end range)
|
|
property value nil)))
|
|
(tp--result-public-value
|
|
(tp--make-result :request request :matches matches))))
|
|
|
|
(cl-defun tp-forward
|
|
(property &optional (value tp-any-value) object n predicate not-current)
|
|
"Search forward N times for text with PROPERTY.
|
|
|
|
Omitted VALUE matches any present direct value; explicit nil matches a
|
|
present nil value. Pass `tp-any-value' when later positional
|
|
arguments are needed with wildcard matching. N is the number of
|
|
searches, defaulting to 1.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
PREDICATE customizes matching: nil (the default) and t both keep the
|
|
`equal' contract; a function is called with VALUE and the run value.
|
|
NOT-CURRENT skips a matching buffer run containing point.
|
|
|
|
For buffers, each search starts from point and each successful one
|
|
moves point to the end of its matched region; the return value is
|
|
the prop-match object of the N-th search, or nil when that search
|
|
found nothing.
|
|
|
|
For strings, point is not involved at all: the return value is the
|
|
list of the FIRST N matching regions counted from position 0 of the
|
|
string, each a (START END VALUE) list with 0-based positions - not
|
|
the N-th match alone. Fewer than N matches return however many
|
|
exist."
|
|
(let ((count (or n 1)))
|
|
(cond
|
|
((stringp object)
|
|
(let ((matches (tp--property-matches
|
|
object 0 (length object) property value predicate)))
|
|
(mapcar #'tp--match-to-list (seq-take matches count))))
|
|
(t
|
|
(let ((result nil)
|
|
(buf (or object (current-buffer))))
|
|
(tp-with-current-buffer buf
|
|
(catch 'done
|
|
(dotimes (_ count)
|
|
(setq result (tp--property-search-forward
|
|
property value predicate not-current))
|
|
(unless result
|
|
(throw 'done nil)))))
|
|
result)))))
|
|
|
|
(cl-defun tp-backward
|
|
(property &optional (value tp-any-value) object n predicate not-current)
|
|
"Search backward N times for text with PROPERTY.
|
|
|
|
N is the number of searches, defaulting to 1.
|
|
Omitted VALUE matches any present direct value; explicit nil matches a
|
|
present nil value. Pass `tp-any-value' when later positional
|
|
arguments are needed with wildcard matching.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
PREDICATE customizes matching: nil (the default) and t both keep the
|
|
0.2.0 contract where a region matches when its PROPERTY value is
|
|
`equal' to VALUE; a function is called with VALUE and the region's
|
|
PROPERTY value and matches when it returns non-nil.
|
|
NOT-CURRENT, when non-nil, skips a matching region containing point
|
|
\(or ending exactly at point), mirroring
|
|
`text-property-search-backward'. It only applies to the buffer
|
|
path; strings have no point, so it is ignored there.
|
|
|
|
For buffers, returns the prop-match object from the last successful search.
|
|
For strings, returns a list of (START END VALUE) for the last N matches
|
|
in reverse order (from end to start).
|
|
|
|
Uses the same presence-aware run scanner for strings and buffers."
|
|
(let ((count (or n 1)))
|
|
(cond
|
|
((stringp object)
|
|
(let ((matches
|
|
(nreverse
|
|
(tp--property-matches
|
|
object 0 (length object) property value predicate))))
|
|
(mapcar #'tp--match-to-list (seq-take matches count))))
|
|
(t
|
|
(let ((result nil)
|
|
(buf (or object (current-buffer))))
|
|
(tp-with-current-buffer buf
|
|
(catch 'done
|
|
(dotimes (_ count)
|
|
(setq result (tp--property-search-backward
|
|
property value predicate not-current))
|
|
(unless result
|
|
(throw 'done nil)))))
|
|
result)))))
|
|
|
|
(cl-defun tp--forward-do
|
|
(function property &optional (value tp-any-value) object times
|
|
start end predicate not-current)
|
|
"Internal: search forward TIMES for PROPERTY, call FUNCTION on last match.
|
|
|
|
FUNCTION receives two arguments: the prop-match object (or list for strings)
|
|
and OBJECT.
|
|
TIMES is the number of searches, defaulting to 1.
|
|
Omitted VALUE matches any present value; explicit nil matches a
|
|
present nil value.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
PREDICATE and NOT-CURRENT are passed to each underlying search (see
|
|
`tp-forward'); nil PREDICATE keeps the 0.2.0 `equal' matching.
|
|
|
|
FUNCTION is called only when the TIMES-th match exists; if fewer
|
|
matches are available, nothing is applied.
|
|
Returns the number of matches found (at most TIMES)."
|
|
(let ((count (or times 1)))
|
|
(cond
|
|
;; String object
|
|
((stringp object)
|
|
(let* ((start-pos (or start 0))
|
|
(end-pos (or end (length object)))
|
|
(all-matches (tp--property-matches
|
|
object start-pos end-pos
|
|
property value predicate))
|
|
(matches (seq-take all-matches count)))
|
|
;; All-or-nothing, mirroring the buffer path: FUNCTION targets
|
|
;; the TIMES-th match specifically, so when fewer matches exist
|
|
;; acting on a different one would hit the wrong target.
|
|
(when (= (length matches) count)
|
|
(funcall function (car (last matches)) object))
|
|
(length matches)))
|
|
;; Buffer or nil
|
|
(t
|
|
(let* ((buf (or object (current-buffer)))
|
|
(matches 0))
|
|
(tp-with-current-buffer buf
|
|
(let ((search-start (or start (point-min)))
|
|
(search-end (or end (point-max))))
|
|
(save-excursion
|
|
(goto-char search-start)
|
|
(dotimes (i count)
|
|
(when-let* ((match (tp--property-search-forward
|
|
property value predicate not-current)))
|
|
(when (<= (prop-match-end match) search-end)
|
|
(when (= i (1- count))
|
|
(funcall function match buf))
|
|
(cl-incf matches)))))))
|
|
matches)))))
|
|
|
|
(defun tp--replace-match-text (function arity match obj &optional idx)
|
|
"Replace the text of MATCH in OBJ with the result of calling FUNCTION.
|
|
|
|
MATCH is either a (START END VALUE) list (string matches) or a
|
|
prop-match struct (buffer matches). ARITY is the precomputed
|
|
\(func-arity FUNCTION); depending on it, FUNCTION is called with
|
|
\(TEXT), (TEXT START), (TEXT START END) or - when IDX is non-nil and
|
|
FUNCTION accepts a 4th argument - (TEXT START END IDX).
|
|
|
|
If FUNCTION returns a string, it replaces the matched text:
|
|
- For string OBJ the replacement happens in place and must have the
|
|
same length as the match. A different length signals an error.
|
|
The replacement's text properties (including their absence) are
|
|
copied onto the replaced portion.
|
|
- For buffer OBJ the match is replaced via `delete-region' + `insert'
|
|
\(the buffer may grow or shrink).
|
|
Any non-string return value leaves OBJ untouched."
|
|
(let* ((range (when (tp--match-p match) (tp--match-range match)))
|
|
(m-start (cond (range (tp--native-range-start range))
|
|
((listp match) (car match))
|
|
(t (prop-match-beginning match))))
|
|
(m-end (cond (range (tp--native-range-end range))
|
|
((listp match) (cadr match))
|
|
(t (prop-match-end match))))
|
|
(text (if (stringp obj)
|
|
(substring obj m-start m-end)
|
|
(buffer-substring m-start m-end)))
|
|
(max-arity (cdr arity))
|
|
(can-accept-start (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 2))))
|
|
(can-accept-end (or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 3))))
|
|
(can-accept-idx (and idx
|
|
(or (eq max-arity 'many)
|
|
(and (numberp max-arity) (>= max-arity 4)))))
|
|
(new-text (cond
|
|
(can-accept-idx (funcall function text m-start m-end idx))
|
|
(can-accept-end (funcall function text m-start m-end))
|
|
(can-accept-start (funcall function text m-start))
|
|
(t (funcall function text)))))
|
|
(when (stringp new-text)
|
|
(if (stringp obj)
|
|
;; For strings: copy text content and properties separately.
|
|
;; A string cannot change length in place, so a replacement
|
|
;; of a different length would silently corrupt the text
|
|
;; (truncation or residue); reject it clearly instead.
|
|
(let ((len (- m-end m-start)))
|
|
(unless (= (length new-text) len)
|
|
(error "TP: replacement %S is %d chars but the match is %d; \
|
|
strings cannot change length in place -- use a buffer OBJECT for \
|
|
length-changing replacements" new-text (length new-text) len))
|
|
(store-substring obj m-start new-text)
|
|
;; Copy properties from new-text to obj. Ranges with nil
|
|
;; properties are copied too, so FUNCTION can REMOVE
|
|
;; properties by returning a stripped string.
|
|
(let ((pos 0))
|
|
(while (< pos len)
|
|
(let* ((props (text-properties-at pos new-text))
|
|
(next-change (or (next-property-change pos new-text)
|
|
len)))
|
|
(set-text-properties (+ m-start pos)
|
|
(+ m-start (min next-change len))
|
|
props
|
|
obj)
|
|
(setq pos next-change)))))
|
|
;; For buffers, delete and insert
|
|
(unless (equal new-text text)
|
|
(save-excursion
|
|
(delete-region m-start m-end)
|
|
(goto-char m-start)
|
|
(insert new-text)))))))
|
|
|
|
(cl-defun tp-forward-do
|
|
(function property &optional (value tp-any-value) object times
|
|
start end predicate not-current)
|
|
"Search forward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
|
|
|
|
Despite the -do suffix this is NOT a for-each: the search advances
|
|
through TIMES matches and FUNCTION is applied only to the final
|
|
\(TIMES-th) one. Use `tp-search-map' to apply a function to EVERY
|
|
match.
|
|
|
|
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
|
|
START and END are the positions of the match. The return value of FUNCTION
|
|
replaces the matched text in the string or buffer.
|
|
|
|
PROPERTY is the text property to search for. Omitted VALUE matches any
|
|
present value; explicit nil matches a present nil value. Pass
|
|
`tp-any-value' when later positional arguments are needed with
|
|
wildcard matching.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
TIMES is the number of searches, defaulting to 1. The function searches
|
|
TIMES times but only applies FUNCTION to the last (Nth) match found.
|
|
START and END define the search range; defaults are object start and end.
|
|
PREDICATE customizes matching: nil (the default) and t both keep the
|
|
0.2.0 contract where a region matches when its PROPERTY value is
|
|
`equal' to VALUE; a function is called with VALUE and the region's
|
|
PROPERTY value and matches when it returns non-nil.
|
|
NOT-CURRENT is passed to each underlying
|
|
`text-property-search-forward' call; it only applies to the buffer
|
|
path (strings have no point).
|
|
|
|
Returns the number of successful matches.
|
|
|
|
Note: For string objects, the replacement text must have the same
|
|
length as the original matched text, since strings have fixed length
|
|
in Emacs; a different length signals an error. Buffer replacements
|
|
may grow or shrink.
|
|
|
|
Example:
|
|
;; Upcase only the last (2nd) match
|
|
(setq my-string (copy-sequence \"hello world hello\"))
|
|
(tp-set 0 5 \\='(marker t) my-string)
|
|
(tp-set 12 17 \\='(marker t) my-string)
|
|
(tp-forward-do #\\='upcase \\='marker tp-any-value my-string 2)
|
|
;; => \"hello world HELLO\" - only the 2nd match is upcased
|
|
|
|
;; Use start and end positions in function
|
|
(tp-forward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
|
|
\\='marker tp-any-value my-string 2)
|
|
|
|
;; Search within a range
|
|
(tp-forward-do #\\='upcase \\='marker tp-any-value my-string 1 0 10)"
|
|
(let ((arity (func-arity function)))
|
|
(tp--forward-do
|
|
(lambda (match obj)
|
|
(tp--replace-match-text function arity match obj))
|
|
property value object times start end predicate not-current)))
|
|
|
|
(cl-defun tp--backward-do
|
|
(function property &optional (value tp-any-value) object times
|
|
start end predicate not-current)
|
|
"Internal: search backward TIMES for PROPERTY, call FUNCTION on last match.
|
|
|
|
FUNCTION receives two arguments: the prop-match object (or list for strings)
|
|
and OBJECT.
|
|
TIMES is the number of searches, defaulting to 1.
|
|
Omitted VALUE matches any present value; explicit nil matches a
|
|
present nil value.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
PREDICATE and NOT-CURRENT are passed to each underlying search (see
|
|
`tp-backward'); nil PREDICATE keeps the 0.2.0 `equal' matching.
|
|
|
|
FUNCTION is called only when the TIMES-th match exists; if fewer
|
|
matches are available, nothing is applied.
|
|
Returns the number of matches found (at most TIMES)."
|
|
(let ((count (or times 1)))
|
|
(cond
|
|
;; String object - reverse the matches
|
|
((stringp object)
|
|
(let* ((start-pos (or start 0))
|
|
(end-pos (or end (length object)))
|
|
(all-matches (tp--property-matches
|
|
object start-pos end-pos
|
|
property value predicate))
|
|
(matches (seq-take (nreverse all-matches) count)))
|
|
;; All-or-nothing; see tp--forward-do.
|
|
(when (= (length matches) count)
|
|
(funcall function (car (last matches)) object))
|
|
(length matches)))
|
|
;; Buffer or nil
|
|
(t
|
|
(let* ((buf (or object (current-buffer)))
|
|
(matches 0))
|
|
(tp-with-current-buffer buf
|
|
(let ((search-start (or start (point-min)))
|
|
(search-end (or end (point-max))))
|
|
(save-excursion
|
|
(goto-char search-end)
|
|
(dotimes (i count)
|
|
;; `equal' matching by default, same as tp--forward-do's
|
|
;; predicate t.
|
|
(when-let* ((match (tp--property-search-backward
|
|
property value predicate not-current)))
|
|
(when (>= (prop-match-beginning match) search-start)
|
|
(when (= i (1- count))
|
|
(funcall function match buf))
|
|
(cl-incf matches)))))))
|
|
matches)))))
|
|
|
|
(cl-defun tp-backward-do
|
|
(function property &optional (value tp-any-value) object times
|
|
start end predicate not-current)
|
|
"Search backward TIMES times for PROPERTY; apply FUNCTION at the Nth match.
|
|
|
|
Despite the -do suffix this is NOT a for-each: the search walks back
|
|
through TIMES matches and FUNCTION is applied only to the final
|
|
\(TIMES-th) one. Use `tp-search-map' to apply a function to EVERY
|
|
match.
|
|
|
|
FUNCTION receives (TEXT &optional START END) where TEXT is the matched text,
|
|
START and END are the positions of the match. The return value of FUNCTION
|
|
replaces the matched text in the string or buffer.
|
|
|
|
PROPERTY is the text property to search for. Omitted VALUE matches any
|
|
present value; explicit nil matches a present nil value. Pass
|
|
`tp-any-value' when later positional arguments are needed with
|
|
wildcard matching.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
TIMES is the number of searches, defaulting to 1. The function searches
|
|
TIMES times but only applies FUNCTION to the last (Nth) match found.
|
|
START and END define the search range; defaults are object start and end.
|
|
PREDICATE customizes matching: nil (the default) and t both keep the
|
|
0.2.0 contract where a region matches when its PROPERTY value is
|
|
`equal' to VALUE; a function is called with VALUE and the region's
|
|
PROPERTY value and matches when it returns non-nil.
|
|
NOT-CURRENT, when non-nil, skips a matching region containing point
|
|
on each underlying search; it only applies to the buffer path
|
|
\(strings have no point).
|
|
|
|
Returns the number of successful matches.
|
|
|
|
Note: For string objects, the replacement text must have the same
|
|
length as the original matched text, since strings have fixed length
|
|
in Emacs; a different length signals an error. Buffer replacements
|
|
may grow or shrink.
|
|
|
|
Example:
|
|
;; Upcase only the last (2nd) match
|
|
(setq my-string (copy-sequence \"hello world hello\"))
|
|
(tp-set 0 5 \\='(marker t) my-string)
|
|
(tp-set 12 17 \\='(marker t) my-string)
|
|
(tp-backward-do #\\='upcase \\='marker tp-any-value my-string 2)
|
|
;; => \"HELLO world hello\" - only the 2nd (last) match is upcased
|
|
|
|
;; Use start and end positions in function
|
|
(tp-backward-do (lambda (txt start end) (format \"[%d-%d]%s\" start end txt))
|
|
\\='marker tp-any-value my-string 2)
|
|
|
|
;; Search within a range
|
|
(tp-backward-do #\\='upcase \\='marker tp-any-value my-string 1 0 10)"
|
|
(let ((arity (func-arity function)))
|
|
(tp--backward-do
|
|
(lambda (match obj)
|
|
(tp--replace-match-text function arity match obj))
|
|
property value object times start end predicate not-current)))
|
|
|
|
(cl-defun tp-search
|
|
(start-or-string
|
|
&optional end-or-property
|
|
(property-or-value tp-any-value property-value-supplied-p)
|
|
(value tp-any-value value-supplied-p)
|
|
object)
|
|
"Search for all text with PROPERTY in a buffer/string range or entire string.
|
|
|
|
This function supports two calling conventions:
|
|
|
|
1. Buffer/string region:
|
|
(tp-search START END PROPERTY &optional VALUE OBJECT)
|
|
|
|
2. Entire string:
|
|
(tp-search STRING PROPERTY &optional VALUE)
|
|
|
|
When VALUE is omitted, match every run where PROPERTY is directly
|
|
present. An explicit nil matches only directly present nil values.
|
|
Use `tp-any-value' explicitly when OBJECT must also be supplied.
|
|
|
|
START-OR-STRING selects the range start or complete string. END-OR-PROPERTY,
|
|
PROPERTY-OR-VALUE, VALUE, and OBJECT complete the selected calling convention.
|
|
|
|
Returns a list of (START END VALUE) lists for all matching regions.
|
|
Each element contains the start position, end position, and property value."
|
|
(cond
|
|
((stringp start-or-string)
|
|
(tp--search-result-value
|
|
start-or-string 0 (length start-or-string) end-or-property
|
|
(if property-value-supplied-p property-or-value tp-any-value)))
|
|
((numberp start-or-string)
|
|
(tp--search-result-value
|
|
(or object (current-buffer)) start-or-string end-or-property
|
|
property-or-value
|
|
(if value-supplied-p value tp-any-value)))
|
|
(t (error "Invalid first argument: %S" start-or-string))))
|
|
|
|
(cl-defun tp--search-do
|
|
(function property &optional (value tp-any-value) object start end)
|
|
"Internal: Execute FUNCTION on all matches of PROPERTY.
|
|
|
|
Signature: (tp--search-do FUNCTION PROPERTY &optional VALUE OBJECT START END)
|
|
|
|
FUNCTION receives two arguments: the match, as a (START END VALUE)
|
|
list, and OBJECT.
|
|
PROPERTY is the text property to search for. Omitted VALUE matches any
|
|
present value; explicit nil matches a present nil value.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of matches processed.
|
|
|
|
For buffers, FUNCTION is called with OBJECT as the current buffer, and
|
|
the match positions handed to FUNCTION are tracked with markers, so
|
|
FUNCTION may safely change the length of earlier matches (e.g. replace
|
|
their text): later matches still receive their up-to-date positions."
|
|
(let ((obj (or object (current-buffer))))
|
|
(if (stringp obj)
|
|
(let* ((s (or start 0))
|
|
(e (or end (length obj)))
|
|
(matches (tp--property-matches
|
|
obj s e property value nil)))
|
|
(dolist (match matches)
|
|
(funcall function (tp--match-to-list match) obj))
|
|
(length matches))
|
|
;; Buffer: do all the work with OBJ current, and track match
|
|
;; positions with markers so length-changing edits made by
|
|
;; FUNCTION on earlier matches don't invalidate later positions.
|
|
(tp-with-current-buffer obj
|
|
(let* ((s (or start (point-min)))
|
|
(e (or end (point-max)))
|
|
(matches (tp--property-matches
|
|
obj s e property value nil))
|
|
(marked (mapcar (lambda (m)
|
|
;; Begin markers advance on insertion at
|
|
;; their position so adjacent runs stay
|
|
;; correct after a replacement.
|
|
(let ((range (tp--match-range m)))
|
|
(list (copy-marker
|
|
(tp--native-range-start range)
|
|
t)
|
|
(copy-marker
|
|
(tp--native-range-end range))
|
|
(tp--match-value m))))
|
|
matches)))
|
|
(unwind-protect
|
|
(dolist (m marked)
|
|
(funcall function
|
|
(list (marker-position (car m))
|
|
(marker-position (cadr m))
|
|
(caddr m))
|
|
obj))
|
|
(dolist (m marked)
|
|
(set-marker (car m) nil)
|
|
(set-marker (cadr m) nil)))
|
|
(length marked))))))
|
|
|
|
(cl-defun tp-search-map
|
|
(function property &optional (value tp-any-value) object start end)
|
|
"Apply FUNCTION to all matches of PROPERTY in OBJECT.
|
|
|
|
Signature: (tp-search-map FUNCTION PROPERTY &optional VALUE OBJECT START END)
|
|
|
|
FUNCTION receives (TEXT &optional START END IDX) where:
|
|
- TEXT is the matched text
|
|
- START and END are the positions of the match
|
|
- IDX is the 0-based index of the current match
|
|
|
|
FUNCTION can either:
|
|
- Return a new/modified string to replace the matched text
|
|
- Modify the text properties of the argument and return it
|
|
- Return nil to skip replacement
|
|
|
|
PROPERTY is the text property to search for. Omitted VALUE matches any
|
|
present value; explicit nil matches a present nil value. Pass
|
|
`tp-any-value' when later positional arguments are needed with
|
|
wildcard matching.
|
|
OBJECT can be a buffer or string; nil defaults to current buffer.
|
|
START and END define the search range; defaults are object start and end.
|
|
|
|
Returns the number of matches processed.
|
|
|
|
Note: For string objects, replacement text must have the same length
|
|
as the original matched text, since strings have fixed length in
|
|
Emacs; a different length signals an error. Buffer replacements may
|
|
grow or shrink.
|
|
|
|
Example:
|
|
;; Upcase all matched text
|
|
(tp-search-map #\\='upcase \\='marker tp-any-value my-string)
|
|
|
|
;; Add properties to matched text
|
|
(tp-search-map (lambda (txt) (tp-add txt \\='face \\='bold))
|
|
\\='marker tp-any-value str)
|
|
|
|
;; Use start, end, and index
|
|
(tp-search-map (lambda (txt start end idx)
|
|
(format \"[%d:%d-%d]%s\" idx start end txt))
|
|
\\='marker tp-any-value str)
|
|
|
|
;; Search within a range
|
|
(tp-search-map #\\='upcase \\='marker tp-any-value my-string 0 10)"
|
|
(let ((idx 0)
|
|
(arity (func-arity function)))
|
|
(tp--search-do
|
|
(lambda (match obj)
|
|
(tp--replace-match-text function arity match obj idx)
|
|
(setq idx (1+ idx)))
|
|
property value object start end)))
|
|
|
|
(provide 'tp-search)
|
|
;;; tp-search.el ends here
|