From 35d570f021b04faa29f52963b556659056ef35e0 Mon Sep 17 00:00:00 2001 From: "copilot-swe-agent[bot]" <198982749+Copilot@users.noreply.github.com> Date: Mon, 15 Dec 2025 10:33:39 +0000 Subject: [PATCH] Update tp-forward-do, tp-backward-do with point parameter and extend tp-at Co-authored-by: Kinneyzhang <38454496+Kinneyzhang@users.noreply.github.com> --- tp-tests.el | 224 +++++++++++++++++++++++++++++++++------------------- tp.el | 209 ++++++++++++++++++++++++++++++------------------ 2 files changed, 277 insertions(+), 156 deletions(-) diff --git a/tp-tests.el b/tp-tests.el index 6aeca2a..25948fa 100644 --- a/tp-tests.el +++ b/tp-tests.el @@ -39,21 +39,21 @@ (insert "Hello World") ;; Set a single property (tp-set 1 6 '(face bold)) - (should (eq (tp-get 1 'face) 'bold)) - (should (eq (tp-get 3 'face) 'bold)) - (should (null (tp-get 7 'face))) + (should (eq (tp-at 1 'face) 'bold)) + (should (eq (tp-at 3 'face) 'bold)) + (should (null (tp-at 7 'face))) ;; Set multiple properties (tp-set 7 12 '(face italic help-echo "test")) - (should (eq (tp-get 7 'face) 'italic)) - (should (equal (tp-get 7 'help-echo) "test")))) + (should (eq (tp-at 7 'face) 'italic)) + (should (equal (tp-at 7 'help-echo) "test")))) (ert-deftest tp-test-put-with-list () "Test tp-set accepts properties as a list." (tp-test-with-temp-buffer (insert "Hello") (tp-set 1 6 '(face bold help-echo "greeting")) - (should (eq (tp-get 1 'face) 'bold)) - (should (equal (tp-get 1 'help-echo) "greeting")))) + (should (eq (tp-at 1 'face) 'bold)) + (should (equal (tp-at 1 'help-echo) "greeting")))) (ert-deftest tp-test-put-returns-region () "Test tp-set returns the modified region." @@ -67,10 +67,10 @@ (tp-test-with-temp-buffer (insert "Hello") (tp-set 1 6 '(face bold help-echo "test")) - (should (eq (tp-get 1 'face) 'bold)) + (should (eq (tp-at 1 'face) 'bold)) (tp-remove 1 6 'face) - (should (null (tp-get 1 'face))) - (should (equal (tp-get 1 'help-echo) "test")))) + (should (null (tp-at 1 'face))) + (should (equal (tp-at 1 'help-echo) "test")))) (ert-deftest tp-test-clear () "Test tp-clear removes all properties." @@ -79,8 +79,8 @@ (tp-set 1 6 '(face bold)) (tp-set 7 12 '(face italic)) (tp-clear 1 12) - (should (null (tp-get 1 'face))) - (should (null (tp-get 7 'face))))) + (should (null (tp-at 1 'face))) + (should (null (tp-at 7 'face))))) (ert-deftest tp-test-clear-defaults-to-buffer () "Test tp-clear defaults to entire buffer." @@ -88,8 +88,8 @@ (insert "Hello World") (tp-set 1 12 '(face bold)) (tp-clear) - (should (null (tp-get 1 'face))) - (should (null (tp-get 7 'face))))) + (should (null (tp-at 1 'face))) + (should (null (tp-at 7 'face))))) (ert-deftest tp-test-at () "Test tp-at returns all properties at point." @@ -100,13 +100,51 @@ (should (eq (plist-get props 'face) 'bold)) (should (equal (plist-get props 'help-echo) "test"))))) +(ert-deftest tp-test-at-with-property () + "Test tp-at returns specific property at point." + (tp-test-with-temp-buffer + (insert "Hello") + (tp-set 1 6 '(face bold help-echo "test")) + (should (eq (tp-at 1 'face) 'bold)) + (should (equal (tp-at 1 'help-echo) "test")) + (should (null (tp-at 1 'mouse-face))))) + +(ert-deftest tp-test-at-with-object () + "Test tp-at with string object." + (let ((str (copy-sequence "Hello World"))) + (tp-set 0 5 '(face bold help-echo "greeting") str) + ;; All properties at position + (let ((props (tp-at 0 str))) + (should (eq (plist-get props 'face) 'bold)) + (should (equal (plist-get props 'help-echo) "greeting"))) + ;; Specific property at position + (should (eq (tp-at 0 'face str) 'bold)) + (should (equal (tp-at 0 'help-echo str) "greeting")))) + +(ert-deftest tp-test-at-with-nested-path () + "Test tp-at with nested property path." + (tp-test-with-temp-buffer + (insert "Hello") + (put-text-property 1 6 'face '(:foreground "red" :box (:color "blue" :line-width 2))) + (should (equal (tp-at 1 '(face :foreground)) "red")) + (should (equal (tp-at 1 '(face :box)) '(:color "blue" :line-width 2))) + (should (equal (tp-at 1 '(face :box :color)) "blue")) + (should (equal (tp-at 1 '(face :box :line-width)) 2)))) + +(ert-deftest tp-test-at-with-nested-path-on-string () + "Test tp-at with nested property path on string." + (let ((str (copy-sequence "Hello World"))) + (put-text-property 0 5 'face '(:foreground "red" :underline (:style wave)) str) + (should (equal (tp-at 0 '(face :foreground) str) "red")) + (should (equal (tp-at 0 '(face :underline :style) str) 'wave)))) + (ert-deftest tp-test-at-defaults-to-point () - "Test tp-at defaults to current point." + "Test tp-at works with current point." (tp-test-with-temp-buffer (insert "Hello") (tp-set 1 6 '(face bold)) (goto-char 3) - (should (eq (plist-get (tp-at) 'face) 'bold)))) + (should (eq (plist-get (tp-at (point)) 'face) 'bold)))) (ert-deftest tp-test-plist () "Test tp-plist merges properties from region." @@ -280,8 +318,8 @@ (insert "Hello") (tp-define-layer layer1 (face bold)) (tp-push-layer 1 6 'layer1) - (should (eq (tp-get 1 'face) 'bold)) - (should (eq (tp-get 1 'tp-name) 'layer1)))) + (should (eq (tp-at 1 'face) 'bold)) + (should (eq (tp-at 1 'tp-name) 'layer1)))) (ert-deftest tp-test-push-layer-multiple () "Test pushing multiple layers." @@ -292,10 +330,10 @@ (tp-push-layer 1 6 'layer1) (tp-push-layer 1 6 'layer2) ;; layer2 should be on top (visible) - (should (eq (tp-get 1 'face) 'italic)) - (should (eq (tp-get 1 'tp-name) 'layer2)) + (should (eq (tp-at 1 'face) 'italic)) + (should (eq (tp-at 1 'tp-name) 'layer2)) ;; layer1 should be in the stack below - (should (tp-get 1 'tp-layers)))) + (should (tp-at 1 'tp-layers)))) (ert-deftest tp-test-delete-layer () "Test tp-delete-layer removes layer from stack." @@ -308,8 +346,8 @@ ;; Delete top layer (tp-delete-layer 1 6 'layer2) ;; layer1 should now be visible - (should (eq (tp-get 1 'face) 'bold)) - (should (eq (tp-get 1 'tp-name) 'layer1)))) + (should (eq (tp-at 1 'face) 'bold)) + (should (eq (tp-at 1 'tp-name) 'layer1)))) (ert-deftest tp-test-delete-layer-from-middle () "Test deleting layer from middle of stack." @@ -324,7 +362,7 @@ ;; Delete middle layer (tp-delete-layer 1 6 'layer2) ;; Top layer should still be visible - (should (eq (tp-get 1 'tp-name) 'layer3)) + (should (eq (tp-at 1 'tp-name) 'layer3)) ;; layer2 should not exist anymore (should-not (tp-layer-exists-p 1 6 'layer2)))) @@ -339,7 +377,7 @@ ;; Pop top layer (tp-pop-layer 1 6) ;; layer1 should now be visible - (should (eq (tp-get 1 'tp-name) 'layer1)))) + (should (eq (tp-at 1 'tp-name) 'layer1)))) (ert-deftest tp-test-rotate-layer () "Test tp-rotate-layer cycles layers." @@ -436,7 +474,7 @@ ;; Should have 1 layer now (should (= (tp-layer-count 1 6) 1)) ;; The merged layer should have properties from both - (should (eq (tp-get 1 'tp-name) 'merged-layer)))) + (should (eq (tp-at 1 'tp-name) 'merged-layer)))) (ert-deftest tp-test-flatten-layers () "Test tp-flatten-layers flattens all layers." @@ -450,7 +488,7 @@ (tp-flatten-layers 1 6 'flat-layer) ;; Should have 1 layer now (should (= (tp-layer-count 1 6) 1)) - (should (eq (tp-get 1 'tp-name) 'flat-layer)))) + (should (eq (tp-at 1 'tp-name) 'flat-layer)))) ;;; ============================================================ ;;; Layer Query Tests @@ -513,8 +551,8 @@ (insert "Hello World Hello") (let ((regions (tp-match "Hello" 'face 'bold))) (should (= (length regions) 2)) - (should (eq (tp-get 1 'face) 'bold)) - (should (eq (tp-get 13 'face) 'bold))))) + (should (eq (tp-at 1 'face) 'bold)) + (should (eq (tp-at 13 'face) 'bold))))) (ert-deftest tp-test-match-returns-regions () "Test tp-match returns correct region pairs." @@ -531,8 +569,8 @@ (insert "abc 123 def 456") (let ((regions (tp-regexp "[0-9]+" 'face 'bold))) (should (= (length regions) 2)) - (should (eq (tp-get 5 'face) 'bold)) - (should (eq (tp-get 13 'face) 'bold))))) + (should (eq (tp-at 5 'face) 'bold)) + (should (eq (tp-at 13 'face) 'bold))))) (ert-deftest tp-test-regexp-returns-regions () "Test tp-regexp returns correct region pairs." @@ -613,7 +651,7 @@ (goto-char 1) (skip-unless (fboundp 'text-property-search-forward)) ;; Test that function receives text and can transform it - (let ((count (tp-forward-do #'upcase 'marker nil nil 2))) + (let ((count (tp-forward-do #'upcase 'marker nil nil nil 2))) (should (= count 2)) ;; Check that text was upcased (should (equal (buffer-substring 1 6) "HELLO")) @@ -631,7 +669,7 @@ (tp--forward-do (lambda (match obj) (push (prop-match-beginning match) result)) - 'marker nil nil 2) + 'marker nil nil nil 2) (should (= (length result) 2))))) (ert-deftest tp-test-backward-do () @@ -643,7 +681,7 @@ (goto-char 18) (skip-unless (fboundp 'text-property-search-backward)) ;; Test that function receives text and can transform it - (let ((count (tp-backward-do #'upcase 'marker nil nil 2))) + (let ((count (tp-backward-do #'upcase 'marker nil nil nil 2))) (should (= count 2)) ;; Check that text was upcased (should (equal (buffer-substring 1 6) "HELLO")) @@ -661,7 +699,7 @@ (tp--backward-do (lambda (match obj) (push (prop-match-beginning match) result)) - 'marker nil nil 2) + 'marker nil nil nil 2) (should (= (length result) 2))))) (ert-deftest tp-test-forward-do-on-string () @@ -669,7 +707,7 @@ (let ((str (copy-sequence "hello World hello"))) (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) - (let ((count (tp-forward-do #'upcase 'marker nil str 2))) + (let ((count (tp-forward-do #'upcase 'marker nil str nil 2))) (should (= count 2)) ;; Check that text was upcased (should (equal (substring str 0 5) "HELLO")) @@ -680,12 +718,38 @@ (let ((str (copy-sequence "hello World hello"))) (tp-set 0 5 '(marker t) str) (tp-set 12 17 '(marker t) str) - (let ((count (tp-backward-do #'upcase 'marker nil str 2))) + (let ((count (tp-backward-do #'upcase 'marker nil str nil 2))) (should (= count 2)) ;; Check that text was upcased (should (equal (substring str 0 5) "HELLO")) (should (equal (substring str 12 17) "HELLO"))))) +(ert-deftest tp-test-forward-do-with-point () + "Test tp-forward-do with point parameter." + (let ((str (copy-sequence "hello World hello"))) + (tp-set 0 5 '(marker t) str) + (tp-set 12 17 '(marker t) str) + ;; Start from position 6 (after first match) + (let ((count (tp-forward-do #'upcase 'marker nil str 6 2))) + (should (= count 1)) ; Only one match from position 6 + ;; First match should NOT be upcased + (should (equal (substring str 0 5) "hello")) + ;; Second match should be upcased + (should (equal (substring str 12 17) "HELLO"))))) + +(ert-deftest tp-test-backward-do-with-point () + "Test tp-backward-do with point parameter." + (let ((str (copy-sequence "hello World hello"))) + (tp-set 0 5 '(marker t) str) + (tp-set 12 17 '(marker t) str) + ;; Start from position 10 (before second match) + (let ((count (tp-backward-do #'upcase 'marker nil str 10 2))) + (should (= count 1)) ; Only one match before position 10 + ;; First match should be upcased + (should (equal (substring str 0 5) "HELLO")) + ;; Second match should NOT be upcased + (should (equal (substring str 12 17) "hello"))))) + (ert-deftest tp-test-search-on-string () "Test tp-search finds all matching properties in a string." (let ((str (copy-sequence "Hello World Hello"))) @@ -813,7 +877,7 @@ ;; Test tp-set alias (insert "Hello") (tp-set 1 6 '(face bold)) - (should (eq (tp-get 1 'face) 'bold)))) + (should (eq (tp-at 1 'face) 'bold)))) ;;; ============================================================ ;;; Edge Case Tests @@ -831,19 +895,19 @@ (insert "Hello World") (tp-set 1 8 '(prop1 val1)) (tp-set 5 12 '(prop2 val2)) - (should (eq (tp-get 1 'prop1) 'val1)) - (should (null (tp-get 1 'prop2))) - (should (eq (tp-get 6 'prop1) 'val1)) - (should (eq (tp-get 6 'prop2) 'val2)) - (should (null (tp-get 10 'prop1))) - (should (eq (tp-get 10 'prop2) 'val2)))) + (should (eq (tp-at 1 'prop1) 'val1)) + (should (null (tp-at 1 'prop2))) + (should (eq (tp-at 6 'prop1) 'val1)) + (should (eq (tp-at 6 'prop2) 'val2)) + (should (null (tp-at 10 'prop1))) + (should (eq (tp-at 10 'prop2) 'val2)))) (ert-deftest tp-test-single-char-region () "Test operations on single character." (tp-test-with-temp-buffer (insert "H") (tp-set 1 2 '(face bold)) - (should (eq (tp-get 1 'face) 'bold)))) + (should (eq (tp-at 1 'face) 'bold)))) (ert-deftest tp-test-layer-on-string () "Test layer operations on string object." @@ -905,8 +969,8 @@ (tp-test-with-temp-buffer (insert "Hello") (tp-set 1 6 '(face bold)) - (should (eq (tp-get 1 'face) 'bold)) - (should (eq (tp-get 3 'face) 'bold)))) + (should (eq (tp-at 1 'face) 'bold)) + (should (eq (tp-at 3 'face) 'bold)))) (ert-deftest tp-test-get-range-property () "Test tp-get with range and specific property. @@ -947,9 +1011,9 @@ Returns list of (START END VALUE) intervals." (tp-set 1 6 '(face bold help-echo "test")) ;; tp-reset should completely replace (tp-reset 1 6 '(mouse-face highlight)) - (should (eq (tp-get 1 'mouse-face) 'highlight)) - (should (null (tp-get 1 'face))) - (should (null (tp-get 1 'help-echo))))) + (should (eq (tp-at 1 'mouse-face) 'highlight)) + (should (null (tp-at 1 'face))) + (should (null (tp-at 1 'help-echo))))) (ert-deftest tp-test-reset-on-string () "Test tp-reset on string." @@ -973,8 +1037,8 @@ Returns list of (START END VALUE) intervals." (tp-set 1 6 '(face bold help-echo "test")) ;; tp-set should only replace specified properties (tp-set 1 6 '(face italic)) - (should (eq (tp-get 1 'face) 'italic)) - (should (equal (tp-get 1 'help-echo) "test")))) + (should (eq (tp-at 1 'face) 'italic)) + (should (equal (tp-at 1 'help-echo) "test")))) (ert-deftest tp-test-set-face () "Test tp-set-face sets only face property." @@ -982,8 +1046,8 @@ Returns list of (START END VALUE) intervals." (insert "Hello") (tp-set 1 6 '(face bold help-echo "test")) (tp-set-face 1 6 'italic) - (should (eq (tp-get 1 'face) 'italic)) - (should (equal (tp-get 1 'help-echo) "test")))) + (should (eq (tp-at 1 'face) 'italic)) + (should (equal (tp-at 1 'help-echo) "test")))) (ert-deftest tp-test-set-face-on-string () "Test tp-set-face on string." @@ -1005,8 +1069,8 @@ Returns list of (START END VALUE) intervals." (insert "Hello") (tp-set 1 6 '(face bold help-echo "test")) (tp-set-display 1 6 '(space :width 10)) - (should (equal (tp-get 1 'display) '(space :width 10))) - (should (eq (tp-get 1 'face) 'bold)))) + (should (equal (tp-at 1 'display) '(space :width 10))) + (should (eq (tp-at 1 'face) 'bold)))) (ert-deftest tp-test-add () "Test tp-add adds/updates properties without replacing." @@ -1014,9 +1078,9 @@ Returns list of (START END VALUE) intervals." (insert "Hello") (tp-set 1 6 '(face bold help-echo "test")) (tp-add 1 6 '(mouse-face highlight)) - (should (eq (tp-get 1 'face) 'bold)) - (should (equal (tp-get 1 'help-echo) "test")) - (should (eq (tp-get 1 'mouse-face) 'highlight)))) + (should (eq (tp-at 1 'face) 'bold)) + (should (equal (tp-at 1 'help-echo) "test")) + (should (eq (tp-at 1 'mouse-face) 'highlight)))) (ert-deftest tp-test-add-deep-merge () "Test tp-add deeply merges nested properties." @@ -1024,7 +1088,7 @@ Returns list of (START END VALUE) intervals." (insert "Hello") (tp-set 1 6 '(face (:foreground "red" :weight bold))) (tp-add 1 6 '(face (:background "blue"))) - (let ((face (tp-get 1 'face))) + (let ((face (tp-at 1 'face))) (should (equal (plist-get face :foreground) "red")) (should (eq (plist-get face :weight) 'bold)) (should (equal (plist-get face :background) "blue"))))) @@ -1038,26 +1102,26 @@ Returns list of (START END VALUE) intervals." (should (equal (get-text-property 0 'help-echo str) "test")))) ;;; ============================================================ -;;; Enhanced tp-get Tests +;;; Enhanced tp-at Tests ;;; ============================================================ -(ert-deftest tp-test-get-nested-sub-property () - "Test tp-get with nested sub-properties." +(ert-deftest tp-test-at-nested-sub-property () + "Test tp-at with nested sub-properties." (tp-test-with-temp-buffer (insert "Hello") (put-text-property 1 6 'face '(:foreground "red" :box (:color "blue" :line-width 2))) - (should (equal (tp-get 1 'face :foreground) "red")) - (should (equal (tp-get 1 'face :box :color) "blue")) - (should (equal (tp-get 1 'face :box :line-width) 2)))) + (should (equal (tp-at 1 '(face :foreground)) "red")) + (should (equal (tp-at 1 '(face :box :color)) "blue")) + (should (equal (tp-at 1 '(face :box :line-width)) 2)))) -(ert-deftest tp-test-get-display-sub-property () - "Test tp-get with display sub-properties that are plists." +(ert-deftest tp-test-at-display-sub-property () + "Test tp-at with display sub-properties that are plists." (tp-test-with-temp-buffer (insert "Hello") ;; Use a plist-style display property (put-text-property 1 6 'display '(:height 1.5 :width 10)) - (should (equal (tp-get 1 'display :height) 1.5)) - (should (equal (tp-get 1 'display :width) 10)))) + (should (equal (tp-at 1 '(display :height)) 1.5)) + (should (equal (tp-at 1 '(display :width)) 10)))) ;;; ============================================================ ;;; Enhanced tp-remove Tests @@ -1070,7 +1134,7 @@ Returns list of (START END VALUE) intervals." (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave :color "blue"))) ;; Remove just :underline from face (tp-remove 1 6 '(face :underline)) - (let ((face (tp-get 1 'face))) + (let ((face (tp-at 1 'face))) (should (equal (plist-get face :foreground) "red")) (should (null (plist-get face :underline)))))) @@ -1081,7 +1145,7 @@ Returns list of (START END VALUE) intervals." (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave :position t :color "blue"))) ;; Remove :style and :position from :underline, keep :color (tp-remove 1 6 '(face :underline (:style :position))) - (let* ((face (tp-get 1 'face)) + (let* ((face (tp-at 1 'face)) (underline (plist-get face :underline))) (should (equal (plist-get face :foreground) "red")) (should (equal (plist-get underline :color) "blue")) @@ -1106,9 +1170,9 @@ Returns list of (START END VALUE) intervals." (insert "Hello World Hello") (tp-set 1 6 '(help-echo "original")) (tp-match-reset "Hello" '(face bold)) - (should (eq (tp-get 1 'face) 'bold)) + (should (eq (tp-at 1 'face) 'bold)) ;; Properties should be completely replaced - (should (null (tp-get 1 'help-echo))))) + (should (null (tp-at 1 'help-echo))))) (ert-deftest tp-test-match-add () "Test tp-match-add adds/updates properties." @@ -1116,9 +1180,9 @@ Returns list of (START END VALUE) intervals." (insert "Hello World Hello") (tp-set 1 6 '(help-echo "original")) (tp-match-add "Hello" '(face bold)) - (should (eq (tp-get 1 'face) 'bold)) + (should (eq (tp-at 1 'face) 'bold)) ;; Original properties should be preserved - (should (equal (tp-get 1 'help-echo) "original")))) + (should (equal (tp-at 1 'help-echo) "original")))) (ert-deftest tp-test-regexp-reset () "Test tp-regexp-reset completely replaces properties." @@ -1126,9 +1190,9 @@ Returns list of (START END VALUE) intervals." (insert "abc 123 def 456") (tp-set 5 8 '(help-echo "original")) (tp-regexp-reset "[0-9]+" '(face bold)) - (should (eq (tp-get 5 'face) 'bold)) + (should (eq (tp-at 5 'face) 'bold)) ;; Properties should be completely replaced - (should (null (tp-get 5 'help-echo))))) + (should (null (tp-at 5 'help-echo))))) (ert-deftest tp-test-regexp-add () "Test tp-regexp-add adds/updates properties." @@ -1136,9 +1200,9 @@ Returns list of (START END VALUE) intervals." (insert "abc 123 def 456") (tp-set 5 8 '(help-echo "original")) (tp-regexp-add "[0-9]+" '(face bold)) - (should (eq (tp-get 5 'face) 'bold)) + (should (eq (tp-at 5 'face) 'bold)) ;; Original properties should be preserved - (should (equal (tp-get 5 'help-echo) "original")))) + (should (equal (tp-at 5 'help-echo) "original")))) (ert-deftest tp-test-match-reset-on-string () "Test tp-match-reset on string." diff --git a/tp.el b/tp.el index 62d7fb1..ca81954 100644 --- a/tp.el +++ b/tp.el @@ -406,59 +406,49 @@ Example: (tp--get-nested \\='(:a 1 :b 2 :c 3) \\='((:a :b))) => (:a 1 :b 2)" (t nil)))) (tp--get-nested next-value rest)))) -(defun tp-get (pos-or-start-or-string &optional property-or-end &rest args) +(defun tp-get (start-or-string &optional end-or-property &rest args) "Get text property value(s) with support for nested sub-properties. This function supports multiple calling conventions: -1. Single position, single property: - (tp-get POSITION PROPERTY) - (tp-get POSITION PROPERTY OBJECT) - -2. Single position, nested sub-property: - (tp-get POSITION PROPERTY SUB-KEY ...) - (tp-get 5 \\='face :foreground) - (tp-get 5 \\='face :box :color) - (tp-get 5 \\='display \\='space :width) - -3. Range with property path as list: +1. Range with property path as list: (tp-get START END \\='(PROPERTY) OBJECT) (tp-get START END \\='(PROPERTY SUB-KEY ...) OBJECT) (tp-get 5 20 \\='(face) str-or-buffer-or-nil) (tp-get 5 20 \\='(face :underline) str-or-buffer-or-nil) (tp-get 5 20 \\='(face :underline :style) str-or-buffer-or-nil) -4. Range, single property: +2. Range, single property: (tp-get START END PROPERTY) (tp-get START END PROPERTY OBJECT) -5. Range, nested sub-property: +3. Range, nested sub-property: (tp-get START END PROPERTY SUB-KEY ...) -6. Range, all properties: +4. Range, all properties: (tp-get START END) (tp-get START END OBJECT) -7. Entire string, all properties: +5. Entire string, all properties: (tp-get STRING) -8. Entire string, single property: +6. Entire string, single property: (tp-get STRING PROPERTY) -9. Entire string, nested sub-property: +7. Entire string, nested sub-property: (tp-get STRING PROPERTY SUB-KEY ...) (tp-get str \\='face) (tp-get str \\='face :underline) (tp-get str \\='face :underline :style) -10. Entire string with property path as list: - (tp-get STRING \\='(PROPERTY SUB-KEY ...)) - (tp-get str \\='(face :foreground)) +8. Entire string with property path as list: + (tp-get STRING \\='(PROPERTY SUB-KEY ...)) + (tp-get str \\='(face :foreground)) -For range and entire string queries, returns a list of (START END VALUE) -intervals, allowing you to see all property values across the range. +Returns a list of (START END VALUE) intervals, allowing you to see all +property values across the range. -For single position queries, returns the property value at that position. +For single position queries, use `tp-at' instead. For buffers, positions are 1-indexed. For strings, positions are 0-indexed. @@ -466,14 +456,14 @@ OBJECT defaults to current buffer." (cond ;; (tp-get STRING ...) - entire string ;; Returns list of (START END VALUE) intervals for all property values - ((stringp pos-or-start-or-string) - (let* ((str pos-or-start-or-string) + ((stringp start-or-string) + (let* ((str start-or-string) (len (length str)) (property nil) (sub-path nil)) (cond ;; (tp-get str) - return all property intervals - ((null property-or-end) + ((null end-or-property) (let ((intervals nil) (pos 0)) (while (< pos len) @@ -484,9 +474,9 @@ OBJECT defaults to current buffer." (setq pos next-pos))) (nreverse intervals))) ;; (tp-get str '(face :foreground)) - property path as list - ((listp property-or-end) - (setq property (car property-or-end)) - (setq sub-path (cdr property-or-end)) + ((listp end-or-property) + (setq property (car end-or-property)) + (setq sub-path (cdr end-or-property)) (let ((intervals nil) (pos 0)) (while (< pos len) @@ -500,8 +490,8 @@ OBJECT defaults to current buffer." (setq pos next-pos))) (nreverse intervals))) ;; (tp-get str 'face ...) - property as symbol with optional sub-path - ((symbolp property-or-end) - (setq property property-or-end) + ((symbolp end-or-property) + (setq property end-or-property) (setq sub-path args) (let ((intervals nil) (pos 0)) @@ -515,28 +505,11 @@ OBJECT defaults to current buffer." (push (list pos next-pos value) intervals)) (setq pos next-pos))) (nreverse intervals)))))) - ;; (tp-get POS PROP ...) or (tp-get POS PROP OBJECT) - single position with symbol property - ((and (numberp pos-or-start-or-string) - (symbolp property-or-end)) - (let* ((prop-value (get-text-property pos-or-start-or-string property-or-end nil)) - ;; Determine if last arg is object or sub-property path - (sub-path args) - (object nil)) - ;; Check if last arg could be an object - (when (and args - (let ((last (car (last args)))) - (or (bufferp last) (stringp last)))) - (setq object (car (last args))) - (setq sub-path (butlast args)) - (setq prop-value (get-text-property pos-or-start-or-string property-or-end object))) - (if sub-path - (tp--get-nested prop-value sub-path) - prop-value))) ;; (tp-get START END ...) - range form - ((and (numberp pos-or-start-or-string) - (numberp property-or-end)) - (let* ((start pos-or-start-or-string) - (end property-or-end) + ((and (numberp start-or-string) + (numberp end-or-property)) + (let* ((start start-or-string) + (end end-or-property) (rest-args args) (property nil) (sub-path nil) @@ -592,11 +565,71 @@ OBJECT defaults to current buffer." (nreverse intervals))))) (t (error "Invalid arguments to tp-get")))) -(defun tp-at (&optional point object) - "Get all text properties at POINT in OBJECT. -POINT defaults to current point. -OBJECT defaults to current buffer." - (text-properties-at (or point (point)) object)) +(defun tp-at (pos &optional property-or-object object) + "Get text properties at POS in OBJECT, optionally filtered by PROPERTY. + +This function supports multiple calling conventions: + +1. Get all properties at position: + (tp-at POS) + (tp-at POS OBJECT) + +2. Get specific property at position: + (tp-at POS PROPERTY) + (tp-at POS PROPERTY OBJECT) + +3. Get nested sub-property at position: + (tp-at POS \\='(PROPERTY SUB-KEY ...)) + (tp-at POS \\='(PROPERTY SUB-KEY ...) OBJECT) + +POS is the position to query. +PROPERTY-OR-OBJECT can be a property symbol/list, or an object (buffer/string). +OBJECT is the buffer or string to query; nil defaults to current buffer. + +For strings, positions are 0-indexed. +For buffers, positions are 1-indexed. + +Examples: + ;; Get all properties at position 5 in current buffer + (tp-at 5) + ;; Get all properties at position 0 in string + (tp-at 0 my-string) + ;; Get face property at position 5 + (tp-at 5 \\='face) + ;; Get face property at position 0 in string + (tp-at 0 \\='face my-string) + ;; Get nested sub-property + (tp-at 5 \\='(face :foreground)) + (tp-at 5 \\='(face :box :color)) + (tp-at 5 \\='(display :width))" + (let ((property nil) + (sub-path nil) + (obj nil)) + ;; Parse arguments + (cond + ;; property-or-object is nil - just get all props + ((null property-or-object) + (setq obj nil)) + ;; property-or-object is a buffer/string - it's the object + ((or (bufferp property-or-object) (stringp property-or-object)) + (setq obj property-or-object)) + ;; property-or-object is a symbol - it's a property + ((symbolp property-or-object) + (setq property property-or-object + obj object)) + ;; property-or-object is a list - it's a property path + ((listp property-or-object) + (setq property (car property-or-object) + sub-path (cdr property-or-object) + obj object)) + (t (error "Invalid PROPERTY-OR-OBJECT argument: %S" property-or-object))) + ;; Get the value + (if property + (let ((prop-value (get-text-property pos property obj))) + (if sub-path + (tp--get-nested prop-value sub-path) + prop-value)) + (text-properties-at pos obj)))) ;;; Private functions for fine-grained property manipulation @@ -1060,7 +1093,7 @@ Uses `tp-search-backward' for buffers and `tp-search' for strings." (setq result (tp-search-backward property value)))) result))))) -(defun tp--forward-do (function property &optional value object n) +(defun tp--forward-do (function property &optional value object point n) "Internal: Search forward N times for PROPERTY and apply FUNCTION to each match. FUNCTION receives two arguments: the prop-match object (or list for strings) @@ -1068,13 +1101,18 @@ and OBJECT. N is the number of searches, defaulting to 1. VALUE is the optional value to match. OBJECT can be a buffer or string; nil defaults to current buffer. +POINT is the starting position for search; for buffers nil means current point, +for strings nil means 0. Returns the number of successful matches." (let ((count (or n 1))) (cond ;; String object ((stringp object) - (let ((matches (seq-take (tp-search object property value) count))) + (let* ((start-pos (or point 0)) + (all-matches (tp-search object property value)) + (filtered-matches (seq-filter (lambda (m) (>= (car m) start-pos)) all-matches)) + (matches (seq-take filtered-matches count))) (dolist (match matches) (funcall function match object)) (length matches))) @@ -1083,13 +1121,15 @@ Returns the number of successful matches." (let ((matches 0) (buf (or object (current-buffer)))) (with-current-buffer buf - (dotimes (_ count) - (when-let ((match (tp-search-forward property value))) - (funcall function match buf) - (cl-incf matches)))) + (save-excursion + (when point (goto-char point)) + (dotimes (_ count) + (when-let ((match (tp-search-forward property value))) + (funcall function match buf) + (cl-incf matches))))) matches))))) -(defun tp-forward-do (function property &optional value object n) +(defun tp-forward-do (function property &optional value object point n) "Search forward N times for text with PROPERTY and apply FUNCTION to each match. FUNCTION receives the matched text as its only argument. The return value @@ -1098,6 +1138,8 @@ of FUNCTION replaces the matched text in the string or buffer. N is the number of searches, defaulting to 1. VALUE is the optional value to match. OBJECT can be a buffer or string; nil defaults to current buffer. +POINT is the starting position for search; for buffers nil means current point, +for strings nil means 0. Returns the number of successful matches. @@ -1108,7 +1150,10 @@ If the replacement is longer, it will be truncated. Example: ;; Upcase all matched text - (tp-forward-do #\\='upcase \\='marker nil my-string 3)" + (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 nil my-string nil 3)" (tp--forward-do (lambda (match obj) (let* ((start (if (listp match) (car match) (prop-match-beginning match))) @@ -1140,9 +1185,9 @@ Example: (delete-region start end) (goto-char start) (insert new-text))))))) - property value object n)) + property value object point n)) -(defun tp--backward-do (function property &optional value object n) +(defun tp--backward-do (function property &optional value object point n) "Internal: Search backward N times for PROPERTY and apply FUNCTION to each match. FUNCTION receives two arguments: the prop-match object (or list for strings) @@ -1150,13 +1195,18 @@ and OBJECT. N is the number of searches, defaulting to 1. VALUE is the optional value to match. OBJECT can be a buffer or string; nil defaults to current buffer. +POINT is the starting position for search; for buffers nil means current point, +for strings nil means end of string. Returns the number of successful matches." (let ((count (or n 1))) (cond ;; String object - reverse the matches ((stringp object) - (let ((matches (seq-take (nreverse (tp-search object property value)) count))) + (let* ((start-pos (or point (length object))) + (all-matches (tp-search object property value)) + (filtered-matches (seq-filter (lambda (m) (<= (cadr m) start-pos)) all-matches)) + (matches (seq-take (nreverse filtered-matches) count))) (dolist (match matches) (funcall function match object)) (length matches))) @@ -1165,13 +1215,15 @@ Returns the number of successful matches." (let ((matches 0) (buf (or object (current-buffer)))) (with-current-buffer buf - (dotimes (_ count) - (when-let ((match (tp-search-backward property value))) - (funcall function match buf) - (cl-incf matches)))) + (save-excursion + (when point (goto-char point)) + (dotimes (_ count) + (when-let ((match (tp-search-backward property value))) + (funcall function match buf) + (cl-incf matches))))) matches))))) -(defun tp-backward-do (function property &optional value object n) +(defun tp-backward-do (function property &optional value object point n) "Search backward N times for text with PROPERTY and apply FUNCTION to each match. FUNCTION receives the matched text as its only argument. The return value @@ -1180,6 +1232,8 @@ of FUNCTION replaces the matched text in the string or buffer. N is the number of searches, defaulting to 1. VALUE is the optional value to match. OBJECT can be a buffer or string; nil defaults to current buffer. +POINT is the starting position for search; for buffers nil means current point, +for strings nil means end of string. Returns the number of successful matches. @@ -1190,7 +1244,10 @@ If the replacement is longer, it will be truncated. Example: ;; Upcase all matched text - (tp-backward-do #\\='upcase \\='marker nil my-string 3)" + (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 nil my-string nil 3)" (tp--backward-do (lambda (match obj) (let* ((start (if (listp match) (car match) (prop-match-beginning match))) @@ -1222,7 +1279,7 @@ Example: (delete-region start end) (goto-char start) (insert new-text))))))) - property value object n)) + property value object point n)) (defun tp-search (start-or-string &optional end-or-property property-or-value value object) "Search for all text with PROPERTY in a buffer/string range or entire string.