branch: externals/hyperbole
commit 43274861b9622bf7547a5b0675555df2d8a4742e
Merge: 1320c37e8b 677d4db578
Author: bw <r...@gnu.org>
Commit: bw <r...@gnu.org>
Merge branch 'rsw-prop-updates' into rsw
---
ChangeLog | 10 +++++++
hsys-org.el | 44 ++++++++++--------------------
hui-em-but.el | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++
test/hsys-org-tests.el | 5 ++--
4 files changed, 99 insertions(+), 32 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 27012fa5a1..9f50703303 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,4 @@
+<<<<<<< HEAD
2024-06-25 Bob Weiner <r...@gnu.org>
* hibtypes.el (hynote): Add for Org and Org Roam links by name.
@@ -10,6 +11,15 @@
evaluation fails.
hmouse-drv.el (hkey-execute, hkey-help): Change 'eval' to 'hypb:eval-debug'
to show a backtrace whenever an error occurs.
+=======
+2024-06-29 Bob Weiner <r...@gnu.org>
+
+* 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.
+>>>>>>> rsw-prop-updates
2024-06-23 Bob Weiner <r...@gnu.org>
diff --git a/hsys-org.el b/hsys-org.el
index 11dbde4471..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: 22-Jun-24 at 23:43:08 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,21 +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-region-with-text-property-value (pos property)
- "Return region around POS that shares its text PROPERTY value, else nil.
-Return the (start . end) buffer positions of the region."
- (when (null pos) (setq pos (point)))
- (let ((property-value (get-text-property pos property))
- (start-point pos))
- (when property-value
- ;; Can't use previous-single-property-change here because it
- ;; ignores characters that lack the property, i.e. have nil values.
- (if (bobp)
- (setq start-point (point-min))
- (while (equal (get-text-property (1- start-point) property)
property-value)
- (setq start-point (1- start-point))))
- (cons start-point (next-single-property-change start-point property)))))
-
(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))
@@ -453,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-text-property-value (point) 'face)))
+ (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.
@@ -461,18 +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 (previous-single-property-change (point) 'face)
(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-text-property-value (point) 'face)))))
+ (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-text-property-value (point) 'face)))
+ (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.
@@ -480,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-text-property-value (point) 'face)))
+ (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.
@@ -488,26 +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 (previous-single-property-change (point) 'face)
(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-text-property-value (point) 'face)))))
+ (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-text-property-value (point) 'face)))
+ (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."
- (let ((face-prop (get-text-property (point) 'face)))
- (when (or (eq face-prop org-face-type)
- (and (listp face-prop) (memq org-face-type face-prop)))
- org-face-type)))
+ (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 9b905d066c..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: 9-Apr-24 at 09:32:53 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-text-property-value 1 'face) '(1 .
4)))))
+ (should (equal (hproperty:char-property-range 1 'face 'org-level-1)
+ '(1 . 4)))))
;; TODO: org-agenda-item-at-p
