972b6d4e4c
Add canonical query semantics, managed metadata and transactions, overlay-aware lookup, reproducible benchmarks, and synchronized API documentation.
211 lines
8.7 KiB
EmacsLisp
211 lines
8.7 KiB
EmacsLisp
;;; tp-native-tests.el --- Native text-property equivalence tests -*- lexical-binding: t -*-
|
|
|
|
;;; Commentary:
|
|
|
|
;; Stage 3/5 tests for the explicit GNU Emacs text/character property
|
|
;; compatibility boundary. Tests compare tp entry points with public Emacs
|
|
;; primitives rather than duplicating their expected implementation.
|
|
|
|
;;; Code:
|
|
|
|
(require 'ert)
|
|
(require 'tp)
|
|
|
|
(ert-deftest tp-native-test-lookup-direct-presence-states ()
|
|
"Direct lookup distinguishes absence, explicit nil, and a value."
|
|
(let ((str (copy-sequence "abc")))
|
|
(put-text-property 0 1 'state nil str)
|
|
(put-text-property 1 2 'state 'ready str)
|
|
(let ((nil-value (tp-lookup 0 'state :object str :mode :text-direct))
|
|
(value (tp-lookup 1 'state :object str :mode :text-direct))
|
|
(absent (tp-lookup 2 'state :object str :mode :text-direct)))
|
|
(should (tp-lookup-result-present-p nil-value))
|
|
(should-not (tp-lookup-result-value nil-value))
|
|
(should (eq (tp-lookup-result-source nil-value) :text-direct))
|
|
(should (tp-lookup-result-present-p value))
|
|
(should (eq (tp-lookup-result-value value) 'ready))
|
|
(should-not (tp-lookup-result-present-p absent))
|
|
(should (eq (tp-lookup-result-source absent) :absent)))))
|
|
|
|
(ert-deftest tp-native-test-lookup-effective-source-matrix ()
|
|
"Source lookup explains direct, category, alias, and default values.
|
|
Like native lookup, a nil alias value falls through to the default."
|
|
(let* ((str (copy-sequence "abcd"))
|
|
(category (make-symbol "tp-native-category"))
|
|
(char-property-alias-alist '((state alternate)))
|
|
(default-text-properties '(state default)))
|
|
(put category 'state 'category)
|
|
(put-text-property 0 1 'state nil str)
|
|
(put-text-property 1 2 'category category str)
|
|
(put-text-property 2 3 'alternate 'alias str)
|
|
(put-text-property 3 4 'alternate nil str)
|
|
(dolist (case '((0 nil :text-direct)
|
|
(1 category :category)
|
|
(2 alias :alias)
|
|
(3 default :default)))
|
|
(pcase-let ((`(,position ,value ,source) case))
|
|
(let ((result (tp-lookup
|
|
position 'state :object str :mode :text-source)))
|
|
(should (tp-lookup-result-present-p result))
|
|
(should (equal (tp-lookup-result-value result) value))
|
|
(should (eq (tp-lookup-result-source result) source))
|
|
(should (equal
|
|
(tp-lookup-result-value
|
|
(tp-lookup position 'state
|
|
:object str :mode :text-effective))
|
|
(get-text-property position 'state str))))))))
|
|
|
|
(ert-deftest tp-native-test-property-change-matches-emacs ()
|
|
"Single/all and next/previous change queries match Emacs primitives."
|
|
(let ((str (copy-sequence "abcdef")))
|
|
(put-text-property 0 3 'state 1 str)
|
|
(put-text-property 3 6 'state 2 str)
|
|
(put-text-property 1 2 'unrelated t str)
|
|
(should (equal
|
|
(tp-property-change
|
|
0 :property 'state :object str :limit 6 :direction :next)
|
|
(next-single-property-change 0 'state str 6)))
|
|
(should (equal
|
|
(tp-property-change 0 :object str :limit 6 :direction :next)
|
|
(next-property-change 0 str 6)))
|
|
(should (equal
|
|
(tp-property-change
|
|
6 :property 'state :object str :limit 0 :direction :previous)
|
|
(previous-single-property-change 6 'state str 0)))
|
|
(should (equal
|
|
(tp-property-change 6 :object str :limit 0 :direction :previous)
|
|
(previous-property-change 6 str 0)))))
|
|
|
|
(ert-deftest tp-native-test-property-any-not-all-match-emacs ()
|
|
"Region equality predicates preserve exact nil behavior."
|
|
(let ((str (copy-sequence "abcd")))
|
|
(put-text-property 0 2 'state nil str)
|
|
(put-text-property 2 4 'state 'ready str)
|
|
(dolist (value '(nil ready missing))
|
|
(should (equal (tp-property-any 0 4 'state value str)
|
|
(text-property-any 0 4 'state value str)))
|
|
(should (equal (tp-property-not-all 0 4 'state value str)
|
|
(text-property-not-all 0 4 'state value str))))))
|
|
|
|
(ert-deftest tp-native-test-mutation-policy-respect-and-inhibit ()
|
|
"Read-only override is explicit and ordinary mode records changes."
|
|
(with-temp-buffer
|
|
(insert "abc")
|
|
(put-text-property 1 2 'read-only t)
|
|
(should-error
|
|
(tp-with-mutation-policy
|
|
'(:modified :ordinary :read-only :respect)
|
|
(tp-set 1 2 '(face bold))))
|
|
(tp-with-mutation-policy
|
|
'(:modified :ordinary :read-only :inhibit)
|
|
(tp-set 1 2 '(face bold)))
|
|
(should (eq (get-text-property 1 'face) 'bold)))
|
|
(with-temp-buffer
|
|
(buffer-enable-undo)
|
|
(insert "abc")
|
|
(setq buffer-undo-list nil)
|
|
(set-buffer-modified-p nil)
|
|
(tp-with-mutation-policy
|
|
'(:modified :ordinary :read-only :respect)
|
|
(tp-set 1 2 '(face bold)))
|
|
(should (buffer-modified-p))
|
|
(should (consp buffer-undo-list))))
|
|
|
|
(ert-deftest tp-native-test-mutation-policy-silent ()
|
|
"Silent property writes keep modified and undo state unchanged."
|
|
(with-temp-buffer
|
|
(buffer-enable-undo)
|
|
(insert "abc")
|
|
(setq buffer-undo-list nil)
|
|
(set-buffer-modified-p nil)
|
|
(tp-with-mutation-policy
|
|
'(:modified :silent :read-only :inhibit)
|
|
(tp-set 1 2 '(face bold)))
|
|
(should (eq (get-text-property 1 'face) 'bold))
|
|
(should-not (buffer-modified-p))
|
|
(should-not buffer-undo-list))
|
|
(should-error
|
|
(tp-with-mutation-policy
|
|
'(:modified :silent :read-only :respect)
|
|
nil))
|
|
(should-error
|
|
(tp-with-mutation-policy '(:unknown t) nil))
|
|
(should-error
|
|
(tp-with-mutation-policy '(:modified nil) nil))
|
|
(should-error
|
|
(tp-with-mutation-policy '(:modified) nil)))
|
|
|
|
(ert-deftest tp-native-test-stickiness-and-insertion-delegation ()
|
|
"tp-set properties retain native insert and insert-and-inherit behavior."
|
|
(with-temp-buffer
|
|
(insert "ab")
|
|
(tp-set 1 2 '(face bold))
|
|
(goto-char 2)
|
|
(insert "x")
|
|
(should-not (get-text-property 2 'face)))
|
|
(with-temp-buffer
|
|
(insert "ab")
|
|
(tp-set 1 2 '(face bold))
|
|
(goto-char 2)
|
|
(insert-and-inherit "x")
|
|
(should (eq (get-text-property 2 'face) 'bold))))
|
|
|
|
(ert-deftest tp-native-test-copy-insert-and-yank-filtering ()
|
|
"Copy and yank primitives preserve/filter tp-applied properties natively."
|
|
(let* ((source (tp-set "abcd" 'face 'bold 'secret 7))
|
|
(copy (copy-sequence source))
|
|
(slice (substring source 1 3)))
|
|
(should (equal-including-properties source copy))
|
|
(should (eq (get-text-property 0 'face slice) 'bold))
|
|
(with-temp-buffer
|
|
(let ((yank-excluded-properties '(secret)))
|
|
(insert-for-yank source))
|
|
(should (eq (get-text-property 1 'face) 'bold))
|
|
(should-not (get-text-property 1 'secret))
|
|
(should (eq (get-text-property
|
|
0 'face (buffer-substring 1 3))
|
|
'bold))
|
|
(should-not (text-properties-at
|
|
0 (buffer-substring-no-properties 1 3))))))
|
|
|
|
(ert-deftest tp-native-test-narrowing-and-indirect-buffer-coordinates ()
|
|
"Public operations keep native positions across narrowing and indirection."
|
|
(let ((base (generate-new-buffer " *tp-native-base*"))
|
|
indirect)
|
|
(unwind-protect
|
|
(progn
|
|
(with-current-buffer base
|
|
(insert "abcdef")
|
|
(setq indirect
|
|
(make-indirect-buffer base " *tp-native-indirect*" t)))
|
|
(with-current-buffer indirect
|
|
(narrow-to-region 2 5)
|
|
(should (equal (tp-set 2 4 '(state shared)) '(2 . 4)))
|
|
(let ((result (tp-lookup 3 'state :mode :text-direct)))
|
|
(should (eq (tp-lookup-result-object result) indirect))
|
|
(should (= (tp-lookup-result-position result) 3))
|
|
(should (eq (tp-lookup-result-value result) 'shared))))
|
|
(with-current-buffer base
|
|
(should (eq (get-text-property 3 'state) 'shared))))
|
|
(when (buffer-live-p indirect) (kill-buffer indirect))
|
|
(when (buffer-live-p base) (kill-buffer base)))))
|
|
|
|
(ert-deftest tp-native-test-emacs-28-required-primitives-exist ()
|
|
"The selected native mapping stays within the Emacs 28.1 baseline."
|
|
(dolist (function '(object-intervals
|
|
text-property-search-forward
|
|
text-property-search-backward
|
|
make-prop-match
|
|
with-silent-modifications
|
|
overlays-at
|
|
get-char-property
|
|
get-char-property-and-overlay
|
|
text-property-any
|
|
text-property-not-all
|
|
previous-single-property-change
|
|
previous-property-change))
|
|
(should (fboundp function))))
|
|
|
|
(provide 'tp-native-tests)
|
|
;;; tp-native-tests.el ends here
|