From 1a1b32a96efa72f538a0c573835e77aa2d00cfa7 Mon Sep 17 00:00:00 2001 From: Jim Porter Date: Mon, 20 May 2024 12:45:13 -0700 Subject: [PATCH] Support text overlays for thingatpt provider helpers * lisp/thingatpt.el (thing-at-point-for-text-property) (forward-thing-for-text-property) (bounds-of-thing-at-point-for-text-property): Rename to... (thing-at-point-for-char-property) (forward-thing-for-char-property) (bounds-of-thing-at-point-for-char-property): ... and add overlay support. Update callers. * test/lisp/thingatpt-tests.el (thing-at-point-providers) (forward-thing-providers, bounds-of-thing-at-point-providers): Test overlays too. * test/lisp/progmodes/bug-reference-tests.el (test-thing-at-point): Test 'bounds-of-thing-at-point' and 'forward-point'. * etc/NEWS: Update function names in announcement. (cherry picked from commit 77ece5709a1d38df8cec33432e77044c308b1d6b) --- etc/NEWS | 6 +-- lisp/net/eww.el | 6 +-- lisp/progmodes/bug-reference.el | 6 +-- lisp/thingatpt.el | 50 +++++++++++++--------- test/lisp/progmodes/bug-reference-tests.el | 5 ++- test/lisp/thingatpt-tests.el | 30 ++++++------- 6 files changed, 57 insertions(+), 46 deletions(-) diff --git a/etc/NEWS b/etc/NEWS index c75f7ee9135..1683434b08a 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1835,9 +1835,9 @@ of 'bounds-of-thing-at-point' and 'forward-thing', respectively. --- *** New helper functions for text property-based thingatpt providers. -The new helper functions 'thing-at-point-for-text-property', -'bounds-of-thing-at-point-for-text-property', and -'forward-thing-for-text-property' can help to help implement custom +The new helper functions 'thing-at-point-for-char-property', +'bounds-of-thing-at-point-for-char-property', and +'forward-thing-for-char-property' can help to help implement custom thingatpt providers for "things" that are defined by a text property. --- diff --git a/lisp/net/eww.el b/lisp/net/eww.el index be43ac2f9db..32e24f9e2e5 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -1380,15 +1380,15 @@ within text input fields." (defun eww--url-at-point () "`thing-at-point' provider function." - (thing-at-point-for-text-property 'shr-url)) + (thing-at-point-for-char-property 'shr-url)) (defun eww--forward-url (backward) "`forward-thing' provider function." - (forward-thing-for-text-property 'shr-url backward)) + (forward-thing-for-char-property 'shr-url backward)) (defun eww--bounds-of-url-at-point () "`bounds-of-thing-at-point' provider function." - (bounds-of-thing-at-point-for-text-property 'shr-url)) + (bounds-of-thing-at-point-for-char-property 'shr-url)) ;;;###autoload (defun eww-browse-url (url &optional new-window) diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 9b8e5c0b106..46163774e47 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -658,15 +658,15 @@ have been run, the auto-setup is inhibited.") (defun bug-reference--url-at-point () "`thing-at-point' provider function." - (thing-at-point-for-text-property 'bug-reference-url)) + (thing-at-point-for-char-property 'bug-reference-url)) (defun bug-reference--forward-url (backward) "`forward-thing' provider function." - (forward-thing-for-text-property 'bug-reference-url backward)) + (forward-thing-for-char-property 'bug-reference-url backward)) (defun bug-reference--bounds-of-url-at-point () "`bounds-of-thing-at-point' provider function." - (bounds-of-thing-at-point-for-text-property 'bug-reference-url)) + (bounds-of-thing-at-point-for-char-property 'bug-reference-url)) (defun bug-reference--init (enable) (if enable diff --git a/lisp/thingatpt.el b/lisp/thingatpt.el index ff0ed66d62d..fe9f5003f0b 100644 --- a/lisp/thingatpt.el +++ b/lisp/thingatpt.el @@ -828,40 +828,48 @@ treated as white space." ;; Provider helper functions -(defun thing-at-point-for-text-property (property) +(defun thing-at-point-for-char-property (property) "Return the \"thing\" at point. -Each \"thing\" is a region of text with the specified text PROPERTY set." - (or (get-text-property (point) property) +Each \"thing\" is a region of text with the specified text PROPERTY (or +overlay) set." + (or (get-char-property (point) property) (and (> (point) (point-min)) - (get-text-property (1- (point)) property)))) + (get-char-property (1- (point)) property)))) (autoload 'text-property-search-forward "text-property-search") (autoload 'text-property-search-backward "text-property-search") (autoload 'prop-match-beginning "text-property-search") (autoload 'prop-match-end "text-property-search") -(defun forward-thing-for-text-property (property &optional backward) +(defun forward-thing-for-char-property (property &optional backward) "Move forward to the end of the next \"thing\". If BACKWARD is non-nil, move backward to the beginning of the previous \"thing\" instead. Each \"thing\" is a region of text with the -specified text PROPERTY set." - (let ((search-func (if backward #'text-property-search-backward - #'text-property-search-forward)) - (pos-func (if backward #'prop-match-beginning #'prop-match-end))) - (when-let ((match (funcall search-func property))) - (goto-char (funcall pos-func match))))) - -(defun bounds-of-thing-at-point-for-text-property (property) +specified text PROPERTY (or overlay) set." + (let ((bounds (bounds-of-thing-at-point-for-char-property property))) + (if backward + (if (and bounds (> (point) (car bounds))) + (goto-char (car bounds)) + (goto-char (previous-single-char-property-change (point) property)) + (unless (get-char-property (point) property) + (goto-char (previous-single-char-property-change + (point) property)))) + (if (and bounds (< (point) (cdr bounds))) + (goto-char (cdr bounds)) + (unless (get-char-property (point) property) + (goto-char (next-single-char-property-change (point) property))) + (goto-char (next-single-char-property-change (point) property)))))) + +(defun bounds-of-thing-at-point-for-char-property (property) "Determine the start and end buffer locations for the \"thing\" at point. -The \"thing\" is a region of text with the specified text PROPERTY set." +The \"thing\" is a region of text with the specified text PROPERTY (or +overlay) set." (let ((pos (point))) - (when (or (get-text-property pos property) + (when (or (get-char-property pos property) (and (> pos (point-min)) - (get-text-property (setq pos (1- pos)) property))) - (cons (or (previous-single-property-change - (min (1+ pos) (point-max)) property) - (point-min)) - (or (next-single-property-change pos property) - (point-max)))))) + (get-char-property (setq pos (1- pos)) property))) + (cons (previous-single-char-property-change + (min (1+ pos) (point-max)) property) + (next-single-char-property-change pos property))))) ;;; thingatpt.el ends here diff --git a/test/lisp/progmodes/bug-reference-tests.el b/test/lisp/progmodes/bug-reference-tests.el index 8cca354705b..21b9d3c8ff3 100644 --- a/test/lisp/progmodes/bug-reference-tests.el +++ b/test/lisp/progmodes/bug-reference-tests.el @@ -136,8 +136,11 @@ (goto-char (point-min)) ;; Make sure we get the URL when `bug-reference-mode' is active... (should (equal (thing-at-point 'url) "https://debbugs.gnu.org/1234")) + (should (equal (bounds-of-thing-at-point 'url) '(1 . 9))) + (should (= (save-excursion (forward-thing 'url) (point)) 9)) (bug-reference-mode -1) ;; ... and get nil when `bug-reference-mode' is inactive. - (should-not (thing-at-point 'url)))) + (should-not (thing-at-point 'url)) + (should-not (bounds-of-thing-at-point 'url)))) ;;; bug-reference-tests.el ends here diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index c3b04f29ce5..cc51e3f5296 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -262,10 +262,10 @@ position to retrieve THING.") (with-temp-buffer (setq-local thing-at-point-provider-alist - `((url . ,(lambda () (thing-at-point-for-text-property 'foo-url))) - (url . ,(lambda () (thing-at-point-for-text-property 'bar-url))))) - (insert (propertize "hello" 'foo-url "foo.com") "\n" - (propertize "goodbye" 'bar-url "bar.com")) + `((url . ,(lambda () (thing-at-point-for-char-property 'foo-url))) + (url . ,(lambda () (thing-at-point-for-char-property 'bar-url))))) + (insert (propertize "hello" 'foo-url "foo.com") "\ngoodbye") + (overlay-put (make-overlay 7 14) 'bar-url "bar.com") (goto-char (point-min)) ;; Get the URL using the first provider. (should (equal (thing-at-point 'url) "foo.com")) @@ -280,10 +280,10 @@ position to retrieve THING.") (with-temp-buffer (setq-local forward-thing-provider-alist - `((url . ,(lambda (n) (forward-thing-for-text-property 'foo-url n))) - (url . ,(lambda (n) (forward-thing-for-text-property 'bar-url n))))) - (insert (propertize "hello" 'foo-url "foo.com") "there\n" - (propertize "goodbye" 'bar-url "bar.com")) + `((url . ,(lambda (n) (forward-thing-for-char-property 'foo-url n))) + (url . ,(lambda (n) (forward-thing-for-char-property 'bar-url n))))) + (insert (propertize "hello" 'foo-url "foo.com") "there\ngoodbye") + (overlay-put (make-overlay 12 19) 'bar-url "bar.com") (goto-char (point-min)) (forward-thing 'url) ; Move past the first URL. (should (= (point) 6)) @@ -301,11 +301,11 @@ position to retrieve THING.") (setq-local bounds-of-thing-at-point-provider-alist `((url . ,(lambda () - (bounds-of-thing-at-point-for-text-property 'foo-url))) + (bounds-of-thing-at-point-for-char-property 'foo-url))) (url . ,(lambda () - (bounds-of-thing-at-point-for-text-property 'bar-url))))) - (insert (propertize "hello" 'foo-url "foo.com") "there\n" - (propertize "goodbye" 'bar-url "bar.com")) + (bounds-of-thing-at-point-for-char-property 'bar-url))))) + (insert (propertize "hello" 'foo-url "foo.com") "there\ngoodbye") + (overlay-put (make-overlay 12 19) 'bar-url "bar.com") (goto-char (point-min)) ;; Look for a URL, using the first provider above. (should (equal (bounds-of-thing-at-point 'url) '(1 . 6))) @@ -325,11 +325,11 @@ position to retrieve THING.") (with-temp-buffer (setq-local thing-at-point-provider-alist - `((url . ,(lambda () (thing-at-point-for-text-property 'url)))) + `((url . ,(lambda () (thing-at-point-for-char-property 'url)))) forward-thing-provider-alist - `((url . ,(lambda (n) (forward-thing-for-text-property 'url n)))) + `((url . ,(lambda (n) (forward-thing-for-char-property 'url n)))) bounds-of-thing-at-point-provider-alist - `((url . ,(lambda () (bounds-of-thing-at-point-for-text-property 'url))))) + `((url . ,(lambda () (bounds-of-thing-at-point-for-char-property 'url))))) (insert (propertize "one" 'url "foo.com") (propertize "two" 'url "bar.com") (propertize "three" 'url "baz.com")) -- 2.39.5