geekinney/tp
1
0
Fork 0
Code Issues Pull Requests Actions 2 Packages Projects Releases Wiki Activity

Update tp-forward-do, tp-backward-do with point parameter and extend tp-at

Browse Source 
Co-authored-by: Kinneyzhang <38454496+Kinneyzhang@users.noreply.github.com>
This commit is contained in:
copilot-swe-agent[bot] 2025-12-15 10:33:39 +00:00
parent 25cd7e98c9
commit 35d570f021
2 changed files with 277 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

224
tp-tests.el
View File

@ -39,21 +39,21 @@
(insert "Hello World") (insert "Hello World")
;; Set a single property ;; Set a single property
(tp-set 1 6 '(face bold)) (tp-set 1 6 '(face bold))
(should (eq (tp-get 1 'face) 'bold)) (should (eq (tp-at 1 'face) 'bold))
(should (eq (tp-get 3 'face) 'bold)) (should (eq (tp-at 3 'face) 'bold))
(should (null (tp-get 7 'face))) (should (null (tp-at 7 'face)))
;; Set multiple properties ;; Set multiple properties
(tp-set 7 12 '(face italic help-echo "test")) (tp-set 7 12 '(face italic help-echo "test"))
(should (eq (tp-get 7 'face) 'italic)) (should (eq (tp-at 7 'face) 'italic))
(should (equal (tp-get 7 'help-echo) "test")))) (should (equal (tp-at 7 'help-echo) "test"))))
(ert-deftest tp-test-put-with-list () (ert-deftest tp-test-put-with-list ()
"Test tp-set accepts properties as a list." "Test tp-set accepts properties as a list."
(tp-test-with-temp-buffer (tp-test-with-temp-buffer
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold help-echo "greeting")) (tp-set 1 6 '(face bold help-echo "greeting"))
(should (eq (tp-get 1 'face) 'bold)) (should (eq (tp-at 1 'face) 'bold))
(should (equal (tp-get 1 'help-echo) "greeting")))) (should (equal (tp-at 1 'help-echo) "greeting"))))
(ert-deftest tp-test-put-returns-region () (ert-deftest tp-test-put-returns-region ()
"Test tp-set returns the modified region." "Test tp-set returns the modified region."
@ -67,10 +67,10 @@
(tp-test-with-temp-buffer (tp-test-with-temp-buffer
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold help-echo "test")) (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) (tp-remove 1 6 'face)
(should (null (tp-get 1 'face))) (should (null (tp-at 1 'face)))
(should (equal (tp-get 1 'help-echo) "test")))) (should (equal (tp-at 1 'help-echo) "test"))))
(ert-deftest tp-test-clear () (ert-deftest tp-test-clear ()
"Test tp-clear removes all properties." "Test tp-clear removes all properties."
@ -79,8 +79,8 @@
(tp-set 1 6 '(face bold)) (tp-set 1 6 '(face bold))
(tp-set 7 12 '(face italic)) (tp-set 7 12 '(face italic))
(tp-clear 1 12) (tp-clear 1 12)
(should (null (tp-get 1 'face))) (should (null (tp-at 1 'face)))
(should (null (tp-get 7 'face))))) (should (null (tp-at 7 'face)))))
(ert-deftest tp-test-clear-defaults-to-buffer () (ert-deftest tp-test-clear-defaults-to-buffer ()
"Test tp-clear defaults to entire buffer." "Test tp-clear defaults to entire buffer."
@ -88,8 +88,8 @@
(insert "Hello World") (insert "Hello World")
(tp-set 1 12 '(face bold)) (tp-set 1 12 '(face bold))
(tp-clear) (tp-clear)
(should (null (tp-get 1 'face))) (should (null (tp-at 1 'face)))
(should (null (tp-get 7 'face))))) (should (null (tp-at 7 'face)))))
(ert-deftest tp-test-at () (ert-deftest tp-test-at ()
"Test tp-at returns all properties at point." "Test tp-at returns all properties at point."
@ -100,13 +100,51 @@
(should (eq (plist-get props 'face) 'bold)) (should (eq (plist-get props 'face) 'bold))
(should (equal (plist-get props 'help-echo) "test"))))) (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 () (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 (tp-test-with-temp-buffer
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold)) (tp-set 1 6 '(face bold))
(goto-char 3) (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 () (ert-deftest tp-test-plist ()
"Test tp-plist merges properties from region." "Test tp-plist merges properties from region."
@ -280,8 +318,8 @@
(insert "Hello") (insert "Hello")
(tp-define-layer layer1 (face bold)) (tp-define-layer layer1 (face bold))
(tp-push-layer 1 6 'layer1) (tp-push-layer 1 6 'layer1)
(should (eq (tp-get 1 'face) 'bold)) (should (eq (tp-at 1 'face) 'bold))
(should (eq (tp-get 1 'tp-name) 'layer1)))) (should (eq (tp-at 1 'tp-name) 'layer1))))
(ert-deftest tp-test-push-layer-multiple () (ert-deftest tp-test-push-layer-multiple ()
"Test pushing multiple layers." "Test pushing multiple layers."
@ -292,10 +330,10 @@
(tp-push-layer 1 6 'layer1) (tp-push-layer 1 6 'layer1)
(tp-push-layer 1 6 'layer2) (tp-push-layer 1 6 'layer2)
;; layer2 should be on top (visible) ;; layer2 should be on top (visible)
(should (eq (tp-get 1 'face) 'italic)) (should (eq (tp-at 1 'face) 'italic))
(should (eq (tp-get 1 'tp-name) 'layer2)) (should (eq (tp-at 1 'tp-name) 'layer2))
;; layer1 should be in the stack below ;; 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 () (ert-deftest tp-test-delete-layer ()
"Test tp-delete-layer removes layer from stack." "Test tp-delete-layer removes layer from stack."
@ -308,8 +346,8 @@
;; Delete top layer ;; Delete top layer
(tp-delete-layer 1 6 'layer2) (tp-delete-layer 1 6 'layer2)
;; layer1 should now be visible ;; layer1 should now be visible
(should (eq (tp-get 1 'face) 'bold)) (should (eq (tp-at 1 'face) 'bold))
(should (eq (tp-get 1 'tp-name) 'layer1)))) (should (eq (tp-at 1 'tp-name) 'layer1))))
(ert-deftest tp-test-delete-layer-from-middle () (ert-deftest tp-test-delete-layer-from-middle ()
"Test deleting layer from middle of stack." "Test deleting layer from middle of stack."
@ -324,7 +362,7 @@
;; Delete middle layer ;; Delete middle layer
(tp-delete-layer 1 6 'layer2) (tp-delete-layer 1 6 'layer2)
;; Top layer should still be visible ;; 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 ;; layer2 should not exist anymore
(should-not (tp-layer-exists-p 1 6 'layer2)))) (should-not (tp-layer-exists-p 1 6 'layer2))))
@ -339,7 +377,7 @@
;; Pop top layer ;; Pop top layer
(tp-pop-layer 1 6) (tp-pop-layer 1 6)
;; layer1 should now be visible ;; 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 () (ert-deftest tp-test-rotate-layer ()
"Test tp-rotate-layer cycles layers." "Test tp-rotate-layer cycles layers."
@ -436,7 +474,7 @@
;; Should have 1 layer now ;; Should have 1 layer now
(should (= (tp-layer-count 1 6) 1)) (should (= (tp-layer-count 1 6) 1))
;; The merged layer should have properties from both ;; 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 () (ert-deftest tp-test-flatten-layers ()
"Test tp-flatten-layers flattens all layers." "Test tp-flatten-layers flattens all layers."
@ -450,7 +488,7 @@
(tp-flatten-layers 1 6 'flat-layer) (tp-flatten-layers 1 6 'flat-layer)
;; Should have 1 layer now ;; Should have 1 layer now
(should (= (tp-layer-count 1 6) 1)) (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 ;;; Layer Query Tests
@ -513,8 +551,8 @@
(insert "Hello World Hello") (insert "Hello World Hello")
(let ((regions (tp-match "Hello" 'face 'bold))) (let ((regions (tp-match "Hello" 'face 'bold)))
(should (= (length regions) 2)) (should (= (length regions) 2))
(should (eq (tp-get 1 'face) 'bold)) (should (eq (tp-at 1 'face) 'bold))
(should (eq (tp-get 13 'face) 'bold))))) (should (eq (tp-at 13 'face) 'bold)))))
(ert-deftest tp-test-match-returns-regions () (ert-deftest tp-test-match-returns-regions ()
"Test tp-match returns correct region pairs." "Test tp-match returns correct region pairs."
@ -531,8 +569,8 @@
(insert "abc 123 def 456") (insert "abc 123 def 456")
(let ((regions (tp-regexp "[0-9]+" 'face 'bold))) (let ((regions (tp-regexp "[0-9]+" 'face 'bold)))
(should (= (length regions) 2)) (should (= (length regions) 2))
(should (eq (tp-get 5 'face) 'bold)) (should (eq (tp-at 5 'face) 'bold))
(should (eq (tp-get 13 'face) 'bold))))) (should (eq (tp-at 13 'face) 'bold)))))
(ert-deftest tp-test-regexp-returns-regions () (ert-deftest tp-test-regexp-returns-regions ()
"Test tp-regexp returns correct region pairs." "Test tp-regexp returns correct region pairs."
@ -613,7 +651,7 @@
(goto-char 1) (goto-char 1)
(skip-unless (fboundp 'text-property-search-forward)) (skip-unless (fboundp 'text-property-search-forward))
;; Test that function receives text and can transform it ;; 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)) (should (= count 2))
;; Check that text was upcased ;; Check that text was upcased
(should (equal (buffer-substring 1 6) "HELLO")) (should (equal (buffer-substring 1 6) "HELLO"))
@ -631,7 +669,7 @@
(tp--forward-do (tp--forward-do
(lambda (match obj) (lambda (match obj)
(push (prop-match-beginning match) result)) (push (prop-match-beginning match) result))
'marker nil nil 2) 'marker nil nil nil 2)
(should (= (length result) 2))))) (should (= (length result) 2)))))
(ert-deftest tp-test-backward-do () (ert-deftest tp-test-backward-do ()
@ -643,7 +681,7 @@
(goto-char 18) (goto-char 18)
(skip-unless (fboundp 'text-property-search-backward)) (skip-unless (fboundp 'text-property-search-backward))
;; Test that function receives text and can transform it ;; 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)) (should (= count 2))
;; Check that text was upcased ;; Check that text was upcased
(should (equal (buffer-substring 1 6) "HELLO")) (should (equal (buffer-substring 1 6) "HELLO"))
@ -661,7 +699,7 @@
(tp--backward-do (tp--backward-do
(lambda (match obj) (lambda (match obj)
(push (prop-match-beginning match) result)) (push (prop-match-beginning match) result))
'marker nil nil 2) 'marker nil nil nil 2)
(should (= (length result) 2))))) (should (= (length result) 2)))))
(ert-deftest tp-test-forward-do-on-string () (ert-deftest tp-test-forward-do-on-string ()
@ -669,7 +707,7 @@
(let ((str (copy-sequence "hello World hello"))) (let ((str (copy-sequence "hello World hello")))
(tp-set 0 5 '(marker t) str) (tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(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)) (should (= count 2))
;; Check that text was upcased ;; Check that text was upcased
(should (equal (substring str 0 5) "HELLO")) (should (equal (substring str 0 5) "HELLO"))
@ -680,12 +718,38 @@
(let ((str (copy-sequence "hello World hello"))) (let ((str (copy-sequence "hello World hello")))
(tp-set 0 5 '(marker t) str) (tp-set 0 5 '(marker t) str)
(tp-set 12 17 '(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)) (should (= count 2))
;; Check that text was upcased ;; Check that text was upcased
(should (equal (substring str 0 5) "HELLO")) (should (equal (substring str 0 5) "HELLO"))
(should (equal (substring str 12 17) "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 () (ert-deftest tp-test-search-on-string ()
"Test tp-search finds all matching properties in a string." "Test tp-search finds all matching properties in a string."
(let ((str (copy-sequence "Hello World Hello"))) (let ((str (copy-sequence "Hello World Hello")))
@ -813,7 +877,7 @@
;; Test tp-set alias ;; Test tp-set alias
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold)) (tp-set 1 6 '(face bold))
(should (eq (tp-get 1 'face) 'bold)))) (should (eq (tp-at 1 'face) 'bold))))
;;; ============================================================ ;;; ============================================================
;;; Edge Case Tests ;;; Edge Case Tests
@ -831,19 +895,19 @@
(insert "Hello World") (insert "Hello World")
(tp-set 1 8 '(prop1 val1)) (tp-set 1 8 '(prop1 val1))
(tp-set 5 12 '(prop2 val2)) (tp-set 5 12 '(prop2 val2))
(should (eq (tp-get 1 'prop1) 'val1)) (should (eq (tp-at 1 'prop1) 'val1))
(should (null (tp-get 1 'prop2))) (should (null (tp-at 1 'prop2)))
(should (eq (tp-get 6 'prop1) 'val1)) (should (eq (tp-at 6 'prop1) 'val1))
(should (eq (tp-get 6 'prop2) 'val2)) (should (eq (tp-at 6 'prop2) 'val2))
(should (null (tp-get 10 'prop1))) (should (null (tp-at 10 'prop1)))
(should (eq (tp-get 10 'prop2) 'val2)))) (should (eq (tp-at 10 'prop2) 'val2))))
(ert-deftest tp-test-single-char-region () (ert-deftest tp-test-single-char-region ()
"Test operations on single character." "Test operations on single character."
(tp-test-with-temp-buffer (tp-test-with-temp-buffer
(insert "H") (insert "H")
(tp-set 1 2 '(face bold)) (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 () (ert-deftest tp-test-layer-on-string ()
"Test layer operations on string object." "Test layer operations on string object."
@ -905,8 +969,8 @@
(tp-test-with-temp-buffer (tp-test-with-temp-buffer
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold)) (tp-set 1 6 '(face bold))
(should (eq (tp-get 1 'face) 'bold)) (should (eq (tp-at 1 'face) 'bold))
(should (eq (tp-get 3 'face) 'bold)))) (should (eq (tp-at 3 'face) 'bold))))
(ert-deftest tp-test-get-range-property () (ert-deftest tp-test-get-range-property ()
"Test tp-get with range and specific 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-set 1 6 '(face bold help-echo "test"))
;; tp-reset should completely replace ;; tp-reset should completely replace
(tp-reset 1 6 '(mouse-face highlight)) (tp-reset 1 6 '(mouse-face highlight))
(should (eq (tp-get 1 'mouse-face) 'highlight)) (should (eq (tp-at 1 'mouse-face) 'highlight))
(should (null (tp-get 1 'face))) (should (null (tp-at 1 'face)))
(should (null (tp-get 1 'help-echo))))) (should (null (tp-at 1 'help-echo)))))
(ert-deftest tp-test-reset-on-string () (ert-deftest tp-test-reset-on-string ()
"Test tp-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 1 6 '(face bold help-echo "test"))
;; tp-set should only replace specified properties ;; tp-set should only replace specified properties
(tp-set 1 6 '(face italic)) (tp-set 1 6 '(face italic))
(should (eq (tp-get 1 'face) 'italic)) (should (eq (tp-at 1 'face) 'italic))
(should (equal (tp-get 1 'help-echo) "test")))) (should (equal (tp-at 1 'help-echo) "test"))))
(ert-deftest tp-test-set-face () (ert-deftest tp-test-set-face ()
"Test tp-set-face sets only face property." "Test tp-set-face sets only face property."
@ -982,8 +1046,8 @@ Returns list of (START END VALUE) intervals."
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold help-echo "test")) (tp-set 1 6 '(face bold help-echo "test"))
(tp-set-face 1 6 'italic) (tp-set-face 1 6 'italic)
(should (eq (tp-get 1 'face) 'italic)) (should (eq (tp-at 1 'face) 'italic))
(should (equal (tp-get 1 'help-echo) "test")))) (should (equal (tp-at 1 'help-echo) "test"))))
(ert-deftest tp-test-set-face-on-string () (ert-deftest tp-test-set-face-on-string ()
"Test tp-set-face on string." "Test tp-set-face on string."
@ -1005,8 +1069,8 @@ Returns list of (START END VALUE) intervals."
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold help-echo "test")) (tp-set 1 6 '(face bold help-echo "test"))
(tp-set-display 1 6 '(space :width 10)) (tp-set-display 1 6 '(space :width 10))
(should (equal (tp-get 1 'display) '(space :width 10))) (should (equal (tp-at 1 'display) '(space :width 10)))
(should (eq (tp-get 1 'face) 'bold)))) (should (eq (tp-at 1 'face) 'bold))))
(ert-deftest tp-test-add () (ert-deftest tp-test-add ()
"Test tp-add adds/updates properties without replacing." "Test tp-add adds/updates properties without replacing."
@ -1014,9 +1078,9 @@ Returns list of (START END VALUE) intervals."
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face bold help-echo "test")) (tp-set 1 6 '(face bold help-echo "test"))
(tp-add 1 6 '(mouse-face highlight)) (tp-add 1 6 '(mouse-face highlight))
(should (eq (tp-get 1 'face) 'bold)) (should (eq (tp-at 1 'face) 'bold))
(should (equal (tp-get 1 'help-echo) "test")) (should (equal (tp-at 1 'help-echo) "test"))
(should (eq (tp-get 1 'mouse-face) 'highlight)))) (should (eq (tp-at 1 'mouse-face) 'highlight))))
(ert-deftest tp-test-add-deep-merge () (ert-deftest tp-test-add-deep-merge ()
"Test tp-add deeply merges nested properties." "Test tp-add deeply merges nested properties."
@ -1024,7 +1088,7 @@ Returns list of (START END VALUE) intervals."
(insert "Hello") (insert "Hello")
(tp-set 1 6 '(face (:foreground "red" :weight bold))) (tp-set 1 6 '(face (:foreground "red" :weight bold)))
(tp-add 1 6 '(face (:background "blue"))) (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 (equal (plist-get face :foreground) "red"))
(should (eq (plist-get face :weight) 'bold)) (should (eq (plist-get face :weight) 'bold))
(should (equal (plist-get face :background) "blue"))))) (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")))) (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 () (ert-deftest tp-test-at-nested-sub-property ()
"Test tp-get with nested sub-properties." "Test tp-at with nested sub-properties."
(tp-test-with-temp-buffer (tp-test-with-temp-buffer
(insert "Hello") (insert "Hello")
(put-text-property 1 6 'face '(:foreground "red" :box (:color "blue" :line-width 2))) (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-at 1 '(face :foreground)) "red"))
(should (equal (tp-get 1 'face :box :color) "blue")) (should (equal (tp-at 1 '(face :box :color)) "blue"))
(should (equal (tp-get 1 'face :box :line-width) 2)))) (should (equal (tp-at 1 '(face :box :line-width)) 2))))
(ert-deftest tp-test-get-display-sub-property () (ert-deftest tp-test-at-display-sub-property ()
"Test tp-get with display sub-properties that are plists." "Test tp-at with display sub-properties that are plists."
(tp-test-with-temp-buffer (tp-test-with-temp-buffer
(insert "Hello") (insert "Hello")
;; Use a plist-style display property ;; Use a plist-style display property
(put-text-property 1 6 'display '(:height 1.5 :width 10)) (put-text-property 1 6 'display '(:height 1.5 :width 10))
(should (equal (tp-get 1 'display :height) 1.5)) (should (equal (tp-at 1 '(display :height)) 1.5))
(should (equal (tp-get 1 'display :width) 10)))) (should (equal (tp-at 1 '(display :width)) 10))))
;;; ============================================================ ;;; ============================================================
;;; Enhanced tp-remove Tests ;;; 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"))) (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave :color "blue")))
;; Remove just :underline from face ;; Remove just :underline from face
(tp-remove 1 6 '(face :underline)) (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 (equal (plist-get face :foreground) "red"))
(should (null (plist-get face :underline)))))) (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"))) (put-text-property 1 6 'face '(:foreground "red" :underline (:style wave :position t :color "blue")))
;; Remove :style and :position from :underline, keep :color ;; Remove :style and :position from :underline, keep :color
(tp-remove 1 6 '(face :underline (:style :position))) (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))) (underline (plist-get face :underline)))
(should (equal (plist-get face :foreground) "red")) (should (equal (plist-get face :foreground) "red"))
(should (equal (plist-get underline :color) "blue")) (should (equal (plist-get underline :color) "blue"))
@ -1106,9 +1170,9 @@ Returns list of (START END VALUE) intervals."
(insert "Hello World Hello") (insert "Hello World Hello")
(tp-set 1 6 '(help-echo "original")) (tp-set 1 6 '(help-echo "original"))
(tp-match-reset "Hello" '(face bold)) (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 ;; 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 () (ert-deftest tp-test-match-add ()
"Test tp-match-add adds/updates properties." "Test tp-match-add adds/updates properties."
@ -1116,9 +1180,9 @@ Returns list of (START END VALUE) intervals."
(insert "Hello World Hello") (insert "Hello World Hello")
(tp-set 1 6 '(help-echo "original")) (tp-set 1 6 '(help-echo "original"))
(tp-match-add "Hello" '(face bold)) (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 ;; 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 () (ert-deftest tp-test-regexp-reset ()
"Test tp-regexp-reset completely replaces properties." "Test tp-regexp-reset completely replaces properties."
@ -1126,9 +1190,9 @@ Returns list of (START END VALUE) intervals."
(insert "abc 123 def 456") (insert "abc 123 def 456")
(tp-set 5 8 '(help-echo "original")) (tp-set 5 8 '(help-echo "original"))
(tp-regexp-reset "[0-9]+" '(face bold)) (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 ;; 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 () (ert-deftest tp-test-regexp-add ()
"Test tp-regexp-add adds/updates properties." "Test tp-regexp-add adds/updates properties."
@ -1136,9 +1200,9 @@ Returns list of (START END VALUE) intervals."
(insert "abc 123 def 456") (insert "abc 123 def 456")
(tp-set 5 8 '(help-echo "original")) (tp-set 5 8 '(help-echo "original"))
(tp-regexp-add "[0-9]+" '(face bold)) (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 ;; 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 () (ert-deftest tp-test-match-reset-on-string ()
"Test tp-match-reset on string." "Test tp-match-reset on string."

193
tp.el
View File

@ -406,59 +406,49 @@ Example: (tp--get-nested \\='(:a 1 :b 2 :c 3) \\='((:a :b))) => (:a 1 :b 2)"
(t nil)))) (t nil))))
(tp--get-nested next-value rest)))) (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. "Get text property value(s) with support for nested sub-properties.
This function supports multiple calling conventions: This function supports multiple calling conventions:
1. Single position, single property: 1. Range with property path as list:
(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:
(tp-get START END \\='(PROPERTY) OBJECT) (tp-get START END \\='(PROPERTY) OBJECT)
(tp-get START END \\='(PROPERTY SUB-KEY ...) OBJECT) (tp-get START END \\='(PROPERTY SUB-KEY ...) OBJECT)
(tp-get 5 20 \\='(face) str-or-buffer-or-nil) (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) str-or-buffer-or-nil)
(tp-get 5 20 \\='(face :underline :style) 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)
(tp-get START END PROPERTY OBJECT) (tp-get START END PROPERTY OBJECT)
5. Range, nested sub-property: 3. Range, nested sub-property:
(tp-get START END PROPERTY SUB-KEY ...) (tp-get START END PROPERTY SUB-KEY ...)
6. Range, all properties: 4. Range, all properties:
(tp-get START END) (tp-get START END)
(tp-get START END OBJECT) (tp-get START END OBJECT)
7. Entire string, all properties: 5. Entire string, all properties:
(tp-get STRING) (tp-get STRING)
8. Entire string, single property: 6. Entire string, single property:
(tp-get STRING 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 STRING PROPERTY SUB-KEY ...)
(tp-get str \\='face) (tp-get str \\='face)
(tp-get str \\='face :underline) (tp-get str \\='face :underline)
(tp-get str \\='face :underline :style) (tp-get str \\='face :underline :style)
10. Entire string with property path as list: 8. Entire string with property path as list:
(tp-get STRING \\='(PROPERTY SUB-KEY ...)) (tp-get STRING \\='(PROPERTY SUB-KEY ...))
(tp-get str \\='(face :foreground)) (tp-get str \\='(face :foreground))
For range and entire string queries, returns a list of (START END VALUE) Returns a list of (START END VALUE) intervals, allowing you to see all
intervals, allowing you to see all property values across the range. 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 buffers, positions are 1-indexed.
For strings, positions are 0-indexed. For strings, positions are 0-indexed.
@ -466,14 +456,14 @@ OBJECT defaults to current buffer."
(cond (cond
;; (tp-get STRING ...) - entire string ;; (tp-get STRING ...) - entire string
;; Returns list of (START END VALUE) intervals for all property values ;; Returns list of (START END VALUE) intervals for all property values
((stringp pos-or-start-or-string) ((stringp start-or-string)
(let* ((str pos-or-start-or-string) (let* ((str start-or-string)
(len (length str)) (len (length str))
(property nil) (property nil)
(sub-path nil)) (sub-path nil))
(cond (cond
;; (tp-get str) - return all property intervals ;; (tp-get str) - return all property intervals
((null property-or-end) ((null end-or-property)
(let ((intervals nil) (let ((intervals nil)
(pos 0)) (pos 0))
(while (< pos len) (while (< pos len)
@ -484,9 +474,9 @@ OBJECT defaults to current buffer."
(setq pos next-pos))) (setq pos next-pos)))
(nreverse intervals))) (nreverse intervals)))
;; (tp-get str '(face :foreground)) - property path as list ;; (tp-get str '(face :foreground)) - property path as list
((listp property-or-end) ((listp end-or-property)
(setq property (car property-or-end)) (setq property (car end-or-property))
(setq sub-path (cdr property-or-end)) (setq sub-path (cdr end-or-property))
(let ((intervals nil) (let ((intervals nil)
(pos 0)) (pos 0))
(while (< pos len) (while (< pos len)
@ -500,8 +490,8 @@ OBJECT defaults to current buffer."
(setq pos next-pos))) (setq pos next-pos)))
(nreverse intervals))) (nreverse intervals)))
;; (tp-get str 'face ...) - property as symbol with optional sub-path ;; (tp-get str 'face ...) - property as symbol with optional sub-path
((symbolp property-or-end) ((symbolp end-or-property)
(setq property property-or-end) (setq property end-or-property)
(setq sub-path args) (setq sub-path args)
(let ((intervals nil) (let ((intervals nil)
(pos 0)) (pos 0))
@ -515,28 +505,11 @@ OBJECT defaults to current buffer."
(push (list pos next-pos value) intervals)) (push (list pos next-pos value) intervals))
(setq pos next-pos))) (setq pos next-pos)))
(nreverse intervals)))))) (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 ;; (tp-get START END ...) - range form
((and (numberp pos-or-start-or-string) ((and (numberp start-or-string)
(numberp property-or-end)) (numberp end-or-property))
(let* ((start pos-or-start-or-string) (let* ((start start-or-string)
(end property-or-end) (end end-or-property)
(rest-args args) (rest-args args)
(property nil) (property nil)
(sub-path nil) (sub-path nil)
@ -592,11 +565,71 @@ OBJECT defaults to current buffer."
(nreverse intervals))))) (nreverse intervals)))))
(t (error "Invalid arguments to tp-get")))) (t (error "Invalid arguments to tp-get"))))
(defun tp-at (&optional point object) (defun tp-at (pos &optional property-or-object object)
"Get all text properties at POINT in OBJECT. "Get text properties at POS in OBJECT, optionally filtered by PROPERTY.
POINT defaults to current point.
OBJECT defaults to current buffer." This function supports multiple calling conventions:
(text-properties-at (or point (point)) object))
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 ;;; 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)))) (setq result (tp-search-backward property value))))
result))))) 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. "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) 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. N is the number of searches, defaulting to 1.
VALUE is the optional value to match. VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer. 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." Returns the number of successful matches."
(let ((count (or n 1))) (let ((count (or n 1)))
(cond (cond
;; String object ;; String object
((stringp 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) (dolist (match matches)
(funcall function match object)) (funcall function match object))
(length matches))) (length matches)))
@ -1083,13 +1121,15 @@ Returns the number of successful matches."
(let ((matches 0) (let ((matches 0)
(buf (or object (current-buffer)))) (buf (or object (current-buffer))))
(with-current-buffer buf (with-current-buffer buf
(save-excursion
(when point (goto-char point))
(dotimes (_ count) (dotimes (_ count)
(when-let ((match (tp-search-forward property value))) (when-let ((match (tp-search-forward property value)))
(funcall function match buf) (funcall function match buf)
(cl-incf matches)))) (cl-incf matches)))))
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. "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 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. N is the number of searches, defaulting to 1.
VALUE is the optional value to match. VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer. 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. Returns the number of successful matches.
@ -1108,7 +1150,10 @@ If the replacement is longer, it will be truncated.
Example: Example:
;; Upcase all matched text ;; 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 (tp--forward-do
(lambda (match obj) (lambda (match obj)
(let* ((start (if (listp match) (car match) (prop-match-beginning match))) (let* ((start (if (listp match) (car match) (prop-match-beginning match)))
@ -1140,9 +1185,9 @@ Example:
(delete-region start end) (delete-region start end)
(goto-char start) (goto-char start)
(insert new-text))))))) (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. "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) 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. N is the number of searches, defaulting to 1.
VALUE is the optional value to match. VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer. 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." Returns the number of successful matches."
(let ((count (or n 1))) (let ((count (or n 1)))
(cond (cond
;; String object - reverse the matches ;; String object - reverse the matches
((stringp object) ((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) (dolist (match matches)
(funcall function match object)) (funcall function match object))
(length matches))) (length matches)))
@ -1165,13 +1215,15 @@ Returns the number of successful matches."
(let ((matches 0) (let ((matches 0)
(buf (or object (current-buffer)))) (buf (or object (current-buffer))))
(with-current-buffer buf (with-current-buffer buf
(save-excursion
(when point (goto-char point))
(dotimes (_ count) (dotimes (_ count)
(when-let ((match (tp-search-backward property value))) (when-let ((match (tp-search-backward property value)))
(funcall function match buf) (funcall function match buf)
(cl-incf matches)))) (cl-incf matches)))))
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. "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 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. N is the number of searches, defaulting to 1.
VALUE is the optional value to match. VALUE is the optional value to match.
OBJECT can be a buffer or string; nil defaults to current buffer. 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. Returns the number of successful matches.
@ -1190,7 +1244,10 @@ If the replacement is longer, it will be truncated.
Example: Example:
;; Upcase all matched text ;; 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 (tp--backward-do
(lambda (match obj) (lambda (match obj)
(let* ((start (if (listp match) (car match) (prop-match-beginning match))) (let* ((start (if (listp match) (car match) (prop-match-beginning match)))
@ -1222,7 +1279,7 @@ Example:
(delete-region start end) (delete-region start end)
(goto-char start) (goto-char start)
(insert new-text))))))) (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) (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. "Search for all text with PROPERTY in a buffer/string range or entire string.