branch: externals/hyperbole
commit 677d4db5788eeac569b354e49ca7d4ef99d0fce7
Author: bw <r...@gnu.org>
Commit: bw <r...@gnu.org>
hui-em-but.el - Add char-property and overlay utility functions
Use these utility functions in "hsys-org.el" and "hsys-org-tests.el".
This adds compatibility with Org mode 9.7 and earlier.
---
ChangeLog | 11 ++++----
hsys-org.el | 58 +++++++++-------------------------------
hui-em-but.el | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++
test/hsys-org-tests.el | 5 ++--
4 files changed, 94 insertions(+), 52 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 13ddf3d370..12e5f5a480 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,9 +1,10 @@
-2024-06-23 Mats Lidell <ma...@gnu.org>
+2024-06-29 Bob Weiner <r...@gnu.org>
-* hsys-org.el (hsys-org-first-face-type-pos)
- (hsys-org-last-face-type-pos, hsys-org-region-with-face-type)
- (hsys-org-is-face-type): Add support for working with org face types
- to be compatible with org mode 9.7 and older versions.
+* hui-em-but.el (hproperty:char-property-start, hproperty:char-property-end,
+ hproperty:char-property-range, hproperty:overlay-range)
+ hproperty:char-property-contains-p):
+ Add char-property and overlay utility functions and use in "hsys-org.el"
+ and "hsys-org-tests.el"; adds compatibility with Org mode 9.7 and earlier.
2024-06-23 Bob Weiner <r...@gnu.org>
diff --git a/hsys-org.el b/hsys-org.el
index 18983bcaf3..4990de9813 100644
--- a/hsys-org.el
+++ b/hsys-org.el
@@ -3,7 +3,7 @@
;; Author: Bob Weiner
;;
;; Orig-Date: 2-Jul-16 at 14:54:14
-;; Last-Mod: 23-Jun-24 at 23:39:40 by Mats Lidell
+;; Last-Mod: 29-Jun-24 at 18:35:13 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -31,7 +31,7 @@
;;; ************************************************************************
(eval-when-compile (require 'hmouse-drv))
-(require 'hbut)
+(require 'hui-em-but) ;; requires 'hbut
(require 'org)
(require 'org-element)
(require 'org-fold nil t)
@@ -368,33 +368,6 @@ Match to all todos if `keyword' is nil or the empty
string."
(org-occur (concat "^" org-outline-regexp " *" (regexp-quote
keyword)))
keyword))
-(defun hsys-org-first-face-type-pos (start org-face-type)
- "Return the first position for property ORG-FACE-TYPE when viewed from
START."
- (let (next)
- (while (and (setq next (previous-single-property-change start 'face))
- (hsys-org-is-face-type org-face-type (get-text-property (1-
next) 'face)))
- (setq start next))
- next))
-
-(defun hsys-org-last-face-type-pos (start org-face-type)
- "Return the last position for property ORG-FACE-TYPE when viewed from START."
- (let ((pos (next-single-property-change start 'face)))
- (while (memq org-face-type (get-text-property pos 'face))
- (setq pos (next-single-property-change pos 'face)))
- pos))
-
-(defun hsys-org-region-with-face-type (pos org-face-type)
- "Return region around POS that shares its ORG-FACE-TYPE value, else nil.
-Return the (start . end) buffer positions of the region."
- (when (null pos) (setq pos (point)))
- (let ((start-point pos))
- (when (hsys-org-is-face-type org-face-type (get-text-property pos 'face))
- (if (bobp)
- (setq start-point (point-min))
- (while (hsys-org-is-face-type org-face-type (get-text-property (1-
start-point) 'face))
- (setq start-point (1- start-point))))
- (cons start-point (hsys-org-last-face-type-pos start-point
org-face-type)))))
-
(defun hsys-org-agenda-item-at-p ()
"Return non-nil if point is on an Org Agenda view item line, else nil."
(and (apply #'derived-mode-p '(org-agenda-mode))
@@ -465,7 +438,7 @@ Assume caller has already checked that the current buffer
is in `org-mode'."
Link region is (start . end) and includes delimiters, else nil."
(and (hsys-org-face-at-p 'org-link)
(equal (get-text-property (point) 'help-echo) "Radio target link")
- (hsys-org-region-with-face-type (point) 'org-link)))
+ (hproperty:char-property-range (point) 'face 'org-link)))
(defun hsys-org-radio-target-def-at-p ()
"Return target region iff point is on a <<<radio target>>> definition.
@@ -473,19 +446,19 @@ Target region is (start . end) and includes any
delimiters, else nil."
(when (hsys-org-target-at-p)
(save-excursion
(unless (looking-at org-radio-target-regexp)
- (goto-char (or (hsys-org-first-face-type-pos (point) 'org-target)
+ (goto-char (or (hproperty:char-property-start (point) 'face 'org-target)
(point-min))))
(when (looking-at "<<<")
(goto-char (match-end 0)))
(and (hsys-org-face-at-p 'org-target)
- (hsys-org-region-with-face-type (point) 'org-target)))))
+ (hproperty:char-property-range (point) 'face 'org-target)))))
(defun hsys-org-radio-target-at-p ()
"Return region iff point is on a <<<radio target>>> or a link to one.
The region is (start . end) and includes any delimiters, else nil."
(and (or (hsys-org-radio-target-def-at-p)
(hsys-org-radio-target-link-at-p))
- (hsys-org-region-with-face-type (point) 'org-target)))
+ (hproperty:char-property-range (point) 'face 'org-target)))
(defun hsys-org-internal-target-link-at-p ()
"Return link text region iff point is on an Org mode internal target link.
@@ -493,7 +466,7 @@ Link region is (start . end) and includes delimiters, else
nil."
(and (hsys-org-face-at-p 'org-link)
(not (equal (get-text-property (point) 'help-echo) "Radio target link"))
(hsys-org-link-at-p)
- (hsys-org-region-with-face-type (point) 'org-link)))
+ (hproperty:char-property-range (point) 'face 'org-link)))
(defun hsys-org-internal-target-def-at-p ()
"Return target region iff point is on <<internal target>> definition.
@@ -501,29 +474,24 @@ Target region is (start . end) and includes any
delimiters, else nil."
(when (hsys-org-target-at-p)
(save-excursion
(unless (looking-at org-target-regexp)
- (goto-char (or (hsys-org-first-face-type-pos (point) 'org-target)
(point-min))))
+ (goto-char (or (hproperty:char-property-start (point) 'face 'org-target)
+ (point-min))))
(when (looking-at "<<")
(goto-char (match-end 0)))
(and (hsys-org-face-at-p 'org-target)
- (hsys-org-region-with-face-type (point) 'org-target)))))
+ (hproperty:char-property-range (point) 'face 'org-target)))))
(defun hsys-org-internal-target-at-p ()
- "Return region iff point is on an <<internal target>> or a link to one.
+ "Return target region iff point is on an <<internal target>> or a link to
one.
The region is (start . end) and includes any delimiters, else nil."
(and (or (hsys-org-internal-target-def-at-p)
(hsys-org-internal-target-link-at-p))
- (hsys-org-region-with-face-type (point) 'org-target)))
-
-(defun hsys-org-is-face-type (org-face-type face-prop)
- "Non-nil if FACE-PROP is a or contain ORG-FACE-TYPE."
- (when (or (eq face-prop org-face-type)
- (and (listp face-prop) (memq org-face-type face-prop)))
- org-face-type))
+ (hproperty:char-property-range (point) 'face 'org-target)))
(defun hsys-org-face-at-p (org-face-type)
"Return ORG-FACE-TYPE iff point is on a character with that face, else nil.
ORG-FACE-TYPE must be a symbol, not a symbol name."
- (hsys-org-is-face-type org-face-type (get-text-property (point) 'face)))
+ (hproperty:char-property-contains-p (point) 'face org-face-type))
;; Adapted from Org code
(defun hsys-org-search-internal-link-p (target)
diff --git a/hui-em-but.el b/hui-em-but.el
index 7bce522728..f455d68b58 100644
--- a/hui-em-but.el
+++ b/hui-em-but.el
@@ -261,6 +261,78 @@ See `hproperty:but-get'."
(add-to-list 'yank-handled-properties '(hproperty:but-face .
hproperty:but-create-on-yank))
+;;; char-property and overlay utility functions
+
+(defun hproperty:char-property-contains-p (pos property value)
+ "At POS if PROPERTY contains VALUE (a symbol), return VALUE, else nil."
+ (let ((val (get-char-property pos property)))
+ (when (or (eq val value)
+ ;; `val' may be a list of property values
+ (and (listp val) (memq value val)))
+ value)))
+
+(defun hproperty:char-property-start (pos property value)
+ "From POS, return the start of text PROPERTY with VALUE overlapping POS.
+Otherwise, return nil. Value must be a symbol."
+ (when-let ((val (hproperty:char-property-contains-p pos property value))
+ (prev pos))
+ ;; Can't use `previous-single-char-property-change' below
+ ;; because it checks for any change in the property value, not
+ ;; just if the property contains the value desired.
+ (while (and (setq prev (1- prev))
+ (>= prev (point-min))
+ (hproperty:char-property-contains-p prev property value)))
+ (max (1+ prev) (point-min))))
+
+(defun hproperty:char-property-end (pos property value)
+ "From POS, return the end of text PROPERTY with VALUE overlapping POS.
+Otherwise, return nil. Value must be a symbol."
+ (when-let ((val (hproperty:char-property-contains-p pos property value))
+ (next pos))
+ ;; Can't use `next-single-char-property-change' below
+ ;; because it checks for any change in the property value, not
+ ;; just if the property contains the value desired.
+ (while (and (setq next (1+ next))
+ (<= next (point-max))
+ (hproperty:char-property-contains-p next property value)))
+ (min next (point-max))))
+
+(defun hproperty:char-property-range (pos property &optional value)
+ "Return a char-property range (start . end) at POS where PROPERTY = VALUE.
+Return nil if no such range. If POS is nil, use point.
+VALUE is optional; if omitted, use the first char-property at POS with
PROPERTY."
+ (unless pos (setq pos (point)))
+ (let ((start pos)
+ (end pos)
+ val)
+ (when (or (null value)
+ (eq value (setq val (hproperty:char-property-contains-p pos
property value))))
+ (setq start (hproperty:char-property-start pos property val)
+ end (hproperty:char-property-end pos property val)))
+ (unless (or (null start) (null end) (= start end))
+ (cons start end))))
+
+(defun hproperty:overlay-range (pos property &optional value)
+ "Return the first overlay range (start . end) at POS where PROPERTY = VALUE.
+Return nil if no such overlay range. If POS is nil, use point.
+VALUE is optional; if omitted, use the first overlay at POS with PROPERTY.
+
+Use `hproperty:char-property-range' for the same capability but for
+both text-properties and overlays."
+ (unless pos (setq pos (point)))
+ (let ((start pos)
+ (end pos)
+ val)
+ (catch 'end
+ (dolist (overlay (overlays-at pos t))
+ (when (and (setq val (overlay-get overlay property))
+ (or (null value) (eq val value)))
+ (setq start (overlay-start overlay)
+ end (overlay-end overlay))
+ (throw 'end nil))))
+ (unless (= start end)
+ (cons start end))))
+
;;; ************************************************************************
;;; Private functions
;;; ************************************************************************
diff --git a/test/hsys-org-tests.el b/test/hsys-org-tests.el
index 01fc3a2f61..2c7258d58b 100644
--- a/test/hsys-org-tests.el
+++ b/test/hsys-org-tests.el
@@ -3,7 +3,7 @@
;; Author: Mats Lidell <ma...@gnu.org>
;;
;; Orig-Date: 23-Apr-21 at 20:55:00
-;; Last-Mod: 23-Jun-24 at 23:08:22 by Mats Lidell
+;; Last-Mod: 29-Jun-24 at 15:13:29 by Bob Weiner
;;
;; SPDX-License-Identifier: GPL-3.0-or-later
;;
@@ -41,7 +41,8 @@
(insert "* 1\n** 2\n*** 3\n")
(goto-char 1)
(font-lock-ensure)
- (should (equal (hsys-org-region-with-face-type 1 'org-level-1) '(1 . 4)))))
+ (should (equal (hproperty:char-property-range 1 'face 'org-level-1)
+ '(1 . 4)))))
;; TODO: org-agenda-item-at-p
