Update tp-forward-do, tp-backward-do with point parameter and extend tp-at
Co-authored-by: Kinneyzhang <38454496+Kinneyzhang@users.noreply.github.com>
This commit is contained in:
copilot-swe-agent[bot]
parent
25cd7e98c9
commit
35d570f021
224
tp-tests.el
224
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."
|
||||
|
||||
209
tp.el
209
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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user