diff options
Diffstat (limited to 'tests')
94 files changed, 3559 insertions, 1268 deletions
diff --git a/tests/run-coverage-file.el b/tests/run-coverage-file.el index 6ac65300b..0d96f1918 100644 --- a/tests/run-coverage-file.el +++ b/tests/run-coverage-file.el @@ -9,7 +9,7 @@ ;; Per-file isolation matches the project's `make test-unit' pattern: ;; each test file runs in its own Emacs process, so tests that work ;; under `make test' will also work under `make coverage'. See -;; docs/design/coverage.org for the rationale. +;; docs/specs/coverage-spec-implemented.org for the rationale. ;;; Code: diff --git a/tests/test-ai-config--apply-model-selection.el b/tests/test-ai-config--apply-model-selection.el new file mode 100644 index 000000000..4ccd6d7a0 --- /dev/null +++ b/tests/test-ai-config--apply-model-selection.el @@ -0,0 +1,45 @@ +;;; test-ai-config--apply-model-selection.el --- Tests for cj/--gptel-apply-model-selection -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--gptel-apply-model-selection is the apply step extracted from the +;; interactive cj/gptel-change-model: it sets gptel-backend/gptel-model globally +;; or buffer-locally and returns the confirmation message. The extraction also +;; dropped a dead `(if (stringp model) ...)' branch (model is always a symbol by +;; that point). + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-config) + +(defvar gptel-backend) +(defvar gptel-model) + +(ert-deftest test-ai-config-apply-model-global-sets-globals () + "Normal: global scope assigns the global vars and reports (global)." + (let ((gptel-backend nil) (gptel-model nil)) + (let ((msg (cj/--gptel-apply-model-selection "global" 'mybackend 'mymodel "MyAI"))) + (should (eq gptel-backend 'mybackend)) + (should (eq gptel-model 'mymodel)) + (should (string-match-p "MyAI" msg)) + (should (string-match-p "mymodel" msg)) + (should (string-match-p "global" msg))))) + +(ert-deftest test-ai-config-apply-model-buffer-sets-buffer-locals () + "Normal: buffer scope makes the vars buffer-local and reports (buffer-local)." + (let ((gptel-backend 'orig) (gptel-model 'origm)) + (with-temp-buffer + (let ((msg (cj/--gptel-apply-model-selection "buffer" 'be 'mo "Name"))) + (should (local-variable-p 'gptel-backend)) + (should (local-variable-p 'gptel-model)) + (should (eq gptel-backend 'be)) + (should (eq gptel-model 'mo)) + (should (string-match-p "buffer-local" msg)))) + ;; outside the temp buffer the globals are untouched + (should (eq gptel-backend 'orig)) + (should (eq gptel-model 'origm)))) + +(provide 'test-ai-config--apply-model-selection) +;;; test-ai-config--apply-model-selection.el ends here diff --git a/tests/test-ai-config-gptel-commands.el b/tests/test-ai-config-gptel-commands.el index b87c4975e..371a75cc8 100644 --- a/tests/test-ai-config-gptel-commands.el +++ b/tests/test-ai-config-gptel-commands.el @@ -77,7 +77,10 @@ (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) (cj/gptel-switch-backend)) (should (eq gptel-backend 'anthropic-backend)) - (should (equal gptel-model "claude-opus")) + ;; gptel-model must be a symbol, not the raw completing-read string: + ;; gptel's modeline calls `symbolp' on it and hangs redisplay otherwise. + (should (symbolp gptel-model)) + (should (eq gptel-model 'claude-opus)) (should (string-match-p "Anthropic - Claude" msg)))) (ert-deftest test-ai-config-switch-backend-error-invalid-choice () diff --git a/tests/test-ai-config-model-to-symbol.el b/tests/test-ai-config-model-to-symbol.el new file mode 100644 index 000000000..de6f18ff8 --- /dev/null +++ b/tests/test-ai-config-model-to-symbol.el @@ -0,0 +1,61 @@ +;;; test-ai-config-model-to-symbol.el --- Tests for cj/gptel--model-to-symbol -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for cj/gptel--model-to-symbol from ai-config.el. +;; +;; Pure function that coerces a model identifier (string, symbol, or other +;; type) to a symbol. `gptel-model' MUST be a symbol -- gptel's modeline +;; code calls `symbolp' on it and signals wrong-type-argument on a string, +;; which manifests as a redisplay hang. The function's invariant is that +;; the result is always a symbol, so a value coerced through it is safe to +;; assign to `gptel-model'. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'testutil-ai-config) +(require 'ai-config) + +;;; Normal Cases + +(ert-deftest test-ai-config-model-to-symbol-normal-string-interns () + "Normal: a string model name is interned to the matching symbol." + (should (eq (cj/gptel--model-to-symbol "claude-opus-4-8") 'claude-opus-4-8))) + +(ert-deftest test-ai-config-model-to-symbol-normal-symbol-returns-symbol () + "Normal: a symbol model name is returned unchanged." + (should (eq (cj/gptel--model-to-symbol 'gpt-4o) 'gpt-4o))) + +(ert-deftest test-ai-config-model-to-symbol-normal-result-always-symbol () + "Normal: the invariant -- the result is always a symbol (the crash guard)." + (should (symbolp (cj/gptel--model-to-symbol "gpt-5.5"))) + (should (symbolp (cj/gptel--model-to-symbol 'gpt-5.5)))) + +;;; Boundary Cases + +(ert-deftest test-ai-config-model-to-symbol-boundary-empty-string-is-symbol () + "Boundary: empty string interns to a symbol (still satisfies the invariant)." + (should (symbolp (cj/gptel--model-to-symbol "")))) + +(ert-deftest test-ai-config-model-to-symbol-boundary-nil-returns-nil () + "Boundary: nil is already a symbol, returned unchanged." + (should (eq (cj/gptel--model-to-symbol nil) nil)) + (should (symbolp (cj/gptel--model-to-symbol nil)))) + +(ert-deftest test-ai-config-model-to-symbol-boundary-string-with-spaces-interns () + "Boundary: a string with spaces interns to a single symbol with that name." + (should (eq (cj/gptel--model-to-symbol "model with spaces") + (intern "model with spaces")))) + +;;; Error/Odd Cases + +(ert-deftest test-ai-config-model-to-symbol-number-formats-then-interns () + "Error: a non-string, non-symbol value is formatted then interned to a symbol." + (should (eq (cj/gptel--model-to-symbol 42) (intern "42"))) + (should (symbolp (cj/gptel--model-to-symbol 42)))) + +(provide 'test-ai-config-model-to-symbol) +;;; test-ai-config-model-to-symbol.el ends here diff --git a/tests/test-ai-term--capture-state.el b/tests/test-ai-term--capture-state.el index 543f83ad7..aa7421350 100644 --- a/tests/test-ai-term--capture-state.el +++ b/tests/test-ai-term--capture-state.el @@ -27,7 +27,9 @@ (should (= cj/--ai-term-last-size (window-body-width right)))))) (ert-deftest test-ai-term--capture-state-below-split-sets-direction () - "Normal: below-split window -> direction=below, integer body-lines matching window." + "Normal: below-split window -> direction=below, integer total-lines matching window. +The vertical axis captures total-height (not body-height) so the toggle +round-trip is immune to the mode line's pixel height." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below)) @@ -36,7 +38,7 @@ (cj/--ai-term-capture-state below) (should (eq cj/--ai-term-last-direction 'below)) (should (integerp cj/--ai-term-last-size)) - (should (= cj/--ai-term-last-size (window-body-height below)))))) + (should (= cj/--ai-term-last-size (window-total-height below)))))) (ert-deftest test-ai-term--capture-state-noop-on-dead-window () "Boundary: nil window -> state remains unchanged." diff --git a/tests/test-ai-term--default-geometry.el b/tests/test-ai-term--default-geometry.el index 833f2ef4c..1180c1979 100644 --- a/tests/test-ai-term--default-geometry.el +++ b/tests/test-ai-term--default-geometry.el @@ -1,15 +1,20 @@ ;;; test-ai-term--default-geometry.el --- Tests for host-aware display defaults -*- lexical-binding: t; -*- ;;; Commentary: -;; ai-term's default display geometry is host-aware: a laptop opens the -;; agent from the bottom (75% height), a desktop opens it from the right -;; (50% width). `cj/--ai-term-default-direction' and -;; `cj/--ai-term-default-size' encapsulate the `env-laptop-p' branch; -;; they feed the default fallbacks in `cj/--ai-term-capture-state' and -;; `cj/--ai-term-display-saved'. +;; ai-term's default display geometry is chosen from the frame's column +;; width: the agent docks from the right (a width fraction) only when a +;; side-by-side split would leave both panes at least +;; `cj/window-dock-min-columns' wide, otherwise from the bottom (a height +;; fraction). `cj/--ai-term-default-direction' reads the frame width and +;; delegates the decision to `cj/preferred-dock-direction' (tested in +;; test-cj-window-geometry-lib.el); `cj/--ai-term-default-size' pairs the +;; size fraction with that direction. They feed the default fallbacks in +;; `cj/--ai-term-capture-state' and `cj/--ai-term-display-saved'. ;; -;; `env-laptop-p' is stubbed per-test so the assertions are deterministic -;; regardless of the host the suite runs on. +;; The direction is tested by stubbing `cj/preferred-dock-direction' (an +;; ordinary defun -- safe to `cl-letf', unlike the frame-* subrs, which +;; would trip the native-comp trampoline trap); the size helper is tested +;; by stubbing the direction defun. ;;; Code: @@ -19,37 +24,48 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'ai-term) -(ert-deftest test-ai-term--default-direction-laptop () - "Normal: on a laptop the default direction is `below'." - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) - (should (eq (cj/--ai-term-default-direction) 'below)))) +(ert-deftest test-ai-term--default-direction-delegates-to-dock-rule () + "Normal: default-direction passes the desktop-width fraction to the dock rule +and returns its verdict." + (let ((cj/ai-term-desktop-width 0.5) + captured) + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (cols frac &rest _) + (setq captured (list cols frac)) + 'below))) + (should (eq (cj/--ai-term-default-direction) 'below)) + ;; the fraction passed is the agent's desktop-width + (should (= (nth 1 captured) 0.5)) + ;; the first argument is a column count (the frame width) + (should (integerp (nth 0 captured)))))) -(ert-deftest test-ai-term--default-direction-desktop () - "Normal: on a desktop the default direction is `right'." - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) +(ert-deftest test-ai-term--default-direction-returns-right-when-rule-says () + "Normal: when the dock rule returns `right', so does default-direction." + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (&rest _) 'right))) (should (eq (cj/--ai-term-default-direction) 'right)))) -(ert-deftest test-ai-term--default-size-laptop () - "Normal: on a laptop the default size is `cj/ai-term-laptop-height'." +(ert-deftest test-ai-term--default-size-pairs-width-with-right () + "Normal: when the direction is `right' the size is the width fraction." (let ((cj/ai-term-laptop-height 0.75) (cj/ai-term-desktop-width 0.5)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) - (should (= (cj/--ai-term-default-size) 0.75))))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) + (should (= (cj/--ai-term-default-size) 0.5))))) -(ert-deftest test-ai-term--default-size-desktop () - "Normal: on a desktop the default size is `cj/ai-term-desktop-width'." +(ert-deftest test-ai-term--default-size-pairs-height-with-below () + "Normal: when the direction is `below' the size is the height fraction." (let ((cj/ai-term-laptop-height 0.75) (cj/ai-term-desktop-width 0.5)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) - (should (= (cj/--ai-term-default-size) 0.5))))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) + (should (= (cj/--ai-term-default-size) 0.75))))) (ert-deftest test-ai-term--default-size-respects-custom-values () "Boundary: the helper returns the customized values, not the literals." (let ((cj/ai-term-laptop-height 0.6) (cj/ai-term-desktop-width 0.33)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) (should (= (cj/--ai-term-default-size) 0.6))) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (should (= (cj/--ai-term-default-size) 0.33))))) (provide 'test-ai-term--default-geometry) diff --git a/tests/test-ai-term--display-rule.el b/tests/test-ai-term--display-rule.el index 906a47680..4a148a5c0 100644 --- a/tests/test-ai-term--display-rule.el +++ b/tests/test-ai-term--display-rule.el @@ -38,7 +38,7 @@ desktop branch; on a laptop the agent would land below instead." (let ((name "agent [display-rule-test]")) (test-ai-term--cleanup name) (unwind-protect - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (test-ai-term--with-clean-frame (let* ((buf (get-buffer-create name)) (win (display-buffer buf))) diff --git a/tests/test-ai-term--display-saved.el b/tests/test-ai-term--display-saved.el index 8b689aa6b..51c22fde9 100644 --- a/tests/test-ai-term--display-saved.el +++ b/tests/test-ai-term--display-saved.el @@ -32,13 +32,12 @@ "Normal: nil state on a desktop -> rightmost, size=cj/ai-term-desktop-width. The cardinal `right' default maps to the frame-edge variant `rightmost' so agent lands at the frame's right edge regardless of -which window is selected. `env-laptop-p' is stubbed nil to pin the -desktop branch." +which window is selected. The default direction is stubbed `right'." (let (received-buf received-alist (cj/--ai-term-last-direction nil) (cj/--ai-term-last-size nil) (cj/ai-term-desktop-width 0.5)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil)) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right)) ((symbol-function 'display-buffer-in-direction) (lambda (b a) (setq received-buf b received-alist a) @@ -49,16 +48,16 @@ desktop branch." (should (= (cdr (assq 'window-width received-alist)) 0.5)) (should (eq (cdr (assq 'inhibit-same-window received-alist)) t)))) -(ert-deftest test-ai-term--display-saved-uses-laptop-defaults-when-state-nil () - "Normal: nil state on a laptop -> bottom, size=cj/ai-term-laptop-height. +(ert-deftest test-ai-term--display-saved-uses-below-default-when-state-nil () + "Normal: nil state with a `below' default -> bottom, size=cj/ai-term-laptop-height. The cardinal `below' default maps to the frame-edge variant `bottom' -and the size lands on the `window-height' axis. `env-laptop-p' is -stubbed t to pin the laptop branch." +and the size lands on the `window-height' axis. The default direction +is stubbed `below' (the size helper follows it)." (let (received-alist (cj/--ai-term-last-direction nil) (cj/--ai-term-last-size nil) (cj/ai-term-laptop-height 0.75)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t)) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below)) ((symbol-function 'display-buffer-in-direction) (lambda (_b a) (setq received-alist a) 'fake-window))) (cj/--ai-term-display-saved 'fake-buf '((inhibit-same-window . t)))) diff --git a/tests/test-ai-term--reuse-edge-window.el b/tests/test-ai-term--reuse-edge-window.el index c41aab73a..a9a0529e8 100644 --- a/tests/test-ai-term--reuse-edge-window.el +++ b/tests/test-ai-term--reuse-edge-window.el @@ -45,7 +45,7 @@ right half: the frame stays at two windows [left | agent]." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((left-buf (get-buffer-create left-name)) (right-buf (get-buffer-create right-name)) (agent-buf (get-buffer-create agent-name))) @@ -77,7 +77,7 @@ bottom half: the frame stays at two windows." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) (let ((top-buf (get-buffer-create top-name)) (bottom-buf (get-buffer-create bottom-name)) (agent-buf (get-buffer-create agent-name))) @@ -107,7 +107,7 @@ the frame goes from one window to two with the agent present." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((sole-buf (get-buffer-create sole-name)) (agent-buf (get-buffer-create agent-name))) (set-window-buffer (selected-window) sole-buf) @@ -133,7 +133,7 @@ ends up displayed." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((top-buf (get-buffer-create top-name)) (bottom-buf (get-buffer-create bottom-name)) (agent-buf (get-buffer-create agent-name))) @@ -165,7 +165,7 @@ window rather than restoring the displaced buffer into a kept slot." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((left-buf (get-buffer-create left-name)) (right-buf (get-buffer-create right-name)) (agent-buf (get-buffer-create agent-name))) @@ -202,7 +202,7 @@ preserved across the toggle (respect-split-width)." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((left-buf (get-buffer-create left-name)) (right-buf (get-buffer-create right-name)) (agent-buf (get-buffer-create agent-name)) @@ -246,7 +246,7 @@ most-recent agent, which would now be the other one." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((a1 (get-buffer-create a1-name)) (a2 (get-buffer-create a2-name)) (left-buf (get-buffer-create left-name)) @@ -269,5 +269,46 @@ most-recent agent, which would now be the other one." (when (get-buffer right-name) (kill-buffer right-name)) (cj/test--kill-agent-buffers)))) +(ert-deftest test-ai-term--reuse-edge-window-3win-toggle-restores-own-window () + "Regression: in a 3-window layout the agent has its own split, so toggling it +off then on restores it as its own window without displacing a working window. +Before the fix, toggle-on reused the bottom edge (the user's main window), +collapsing three windows to two and hiding the main buffer. A toggle must be +reversible: off then on returns to the same layout." + (cj/test--kill-agent-buffers) + (let ((agent-name "agent [3win-toggle]") + (code-name "*test-3win-code*") + (main-name "*test-3win-main*") + (cj/--ai-term-last-direction nil) + (cj/--ai-term-last-size nil) + (cj/--ai-term-last-was-bury nil)) + (unwind-protect + (save-window-excursion + (delete-other-windows) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) + (let ((code-buf (get-buffer-create code-name)) + (main-buf (get-buffer-create main-name)) + (agent-buf (get-buffer-create agent-name))) + (set-window-buffer (selected-window) code-buf) + (let* ((main-win (split-window (selected-window) nil 'below)) + (agent-win (split-window main-win nil 'below))) + (set-window-buffer main-win main-buf) + (set-window-buffer agent-win agent-buf) + (should (= (count-windows) 3)) + (let ((display-buffer-alist (cj/--ai-term-display-rule-list))) + (select-window agent-win) + (cj/test--call-as-gui #'cj/ai-term) ; off -> code | main + (should (= (count-windows) 2)) + (should-not (member agent-name (cj/test--displayed-buffer-names))) + (cj/test--call-as-gui #'cj/ai-term) ; on -> back to 3 windows + (should (= (count-windows) 3)) + (let ((bufs (cj/test--displayed-buffer-names))) + (should (member agent-name bufs)) + (should (member code-name bufs)) + (should (member main-name bufs)))))))) + (when (get-buffer code-name) (kill-buffer code-name)) + (when (get-buffer main-name) (kill-buffer main-name)) + (cj/test--kill-agent-buffers)))) + (provide 'test-ai-term--reuse-edge-window) ;;; test-ai-term--reuse-edge-window.el ends here diff --git a/tests/test-auth-config--plstore-read-fixed.el b/tests/test-auth-config--plstore-read-fixed.el new file mode 100644 index 000000000..4b14a4a0c --- /dev/null +++ b/tests/test-auth-config--plstore-read-fixed.el @@ -0,0 +1,101 @@ +;;; test-auth-config--plstore-read-fixed.el --- Tests for the oauth2-auto cache fix -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `cj/oauth2-auto--plstore-read-fixed' in auth-config.el — the +;; advice that re-enables oauth2-auto's plstore cache. oauth2-auto is not +;; installed here, so its symbols and the plstore I/O are stubbed at the +;; boundary; the function's own logic (cache-first read, puthash, the +;; unwind-protect close) runs for real. `require' is stubbed to no-op only +;; for oauth2-auto (other requires delegate through), satisfying the +;; function's `(require 'oauth2-auto)' without loading or provide-ing the +;; package (a provide would fire auth-config's advice-add side effect). + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'plstore) +(require 'auth-config) + +;; Declared special so the function (which reads these as free package +;; globals) sees the dynamic let-bindings the tests establish. +(defvar oauth2-auto--plstore-cache nil) +(defvar oauth2-auto-plstore nil) + +(defvar test-auth--open-count 0 "Times plstore-open was called in a test.") +(defvar test-auth--closed nil "Whether plstore-close ran in a test.") +(defvar test-auth--get-fn nil "Stub behavior for plstore-get: (lambda (ps id) ...).") + +(defmacro test-auth--with-env (&rest body) + "Run BODY with a faked oauth2-auto + plstore environment. +Resets the open counter and closed flag and gives a fresh cache each time." + (declare (indent 0)) + `(let* ((oauth2-auto--plstore-cache (make-hash-table :test 'equal)) + (oauth2-auto-plstore "/tmp/oauth2-test.plist") + (test-auth--open-count 0) + (test-auth--closed nil) + (orig-require (symbol-function 'require))) + (cl-letf (((symbol-function 'require) + (lambda (feat &rest args) + (if (eq feat 'oauth2-auto) + 'oauth2-auto + (apply orig-require feat args)))) + ((symbol-function 'oauth2-auto--compute-id) + (lambda (_u _p) "ID")) + ((symbol-function 'plstore-open) + (lambda (_f) (cl-incf test-auth--open-count) 'PS)) + ((symbol-function 'plstore-get) + (lambda (ps id) (funcall test-auth--get-fn ps id))) + ((symbol-function 'plstore-close) + (lambda (_p) (setq test-auth--closed t)))) + ,@body))) + +;;; Normal Cases + +(ert-deftest test-auth-config-plstore-read-fixed-cache-hit () + "Normal: a cache hit returns the cached value without opening the plstore." + (let ((test-auth--get-fn (lambda (_ps _id) (error "should not read")))) + (test-auth--with-env + (puthash "ID" "CACHED" oauth2-auto--plstore-cache) + (should (equal (cj/oauth2-auto--plstore-read-fixed "u" "p") "CACHED")) + (should (= test-auth--open-count 0))))) + +(ert-deftest test-auth-config-plstore-read-fixed-cache-miss-reads-and-caches () + "Normal: a miss reads from the plstore, caches the value, and closes." + (let ((test-auth--get-fn (lambda (_ps id) (cons id "TOK")))) + (test-auth--with-env + (should (equal (cj/oauth2-auto--plstore-read-fixed "u" "p") "TOK")) + (should (equal (gethash "ID" oauth2-auto--plstore-cache) "TOK")) + (should (= test-auth--open-count 1)) + (should test-auth--closed)))) + +;;; Boundary Cases + +(ert-deftest test-auth-config-plstore-read-fixed-value-cached-after-first-read () + "Boundary: a non-nil value is cached, so a second call does not re-open." + (let ((test-auth--get-fn (lambda (_ps id) (cons id "TOK")))) + (test-auth--with-env + (cj/oauth2-auto--plstore-read-fixed "u" "p") + (cj/oauth2-auto--plstore-read-fixed "u" "p") + (should (= test-auth--open-count 1))))) + +(ert-deftest test-auth-config-plstore-read-fixed-nil-value-rereads () + "Boundary: a nil value caches nil, so every call re-opens the plstore. +This documents current behavior — `gethash' on a nil entry is a miss." + (let ((test-auth--get-fn (lambda (_ps _id) (cons "ID" nil)))) + (test-auth--with-env + (should-not (cj/oauth2-auto--plstore-read-fixed "u" "p")) + (should-not (cj/oauth2-auto--plstore-read-fixed "u" "p")) + (should (= test-auth--open-count 2))))) + +;;; Error Cases + +(ert-deftest test-auth-config-plstore-read-fixed-closes-on-error () + "Error: a read failure still closes the plstore via unwind-protect." + (let ((test-auth--get-fn (lambda (&rest _) (error "boom")))) + (test-auth--with-env + (should-error (cj/oauth2-auto--plstore-read-fixed "u" "p")) + (should test-auth--closed)))) + +(provide 'test-auth-config--plstore-read-fixed) +;;; test-auth-config--plstore-read-fixed.el ends here diff --git a/tests/test-browser-config.el b/tests/test-browser-config.el index 7faecbfc8..9fe5b02e4 100644 --- a/tests/test-browser-config.el +++ b/tests/test-browser-config.el @@ -273,29 +273,6 @@ (should (string= (plist-get loaded :name) "Second")))) (test-browser-teardown)) -;;; Public wrappers (message side-effects mocked) - -(ert-deftest test-browser-apply-wrapper-success-messages-name () - "Normal: =cj/apply-browser-choice= reports the chosen name on success." - (test-browser-setup) - (let ((browser (test-browser-make-plist "Wrapper Test")) - (received nil)) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq received (apply #'format fmt args))))) - (cj/apply-browser-choice browser)) - (should (string-match-p "Wrapper Test" received)) - (should (string-match-p "Default browser set" received))) - (test-browser-teardown)) - -(ert-deftest test-browser-apply-wrapper-invalid-plist-messages-error () - "Error: =cj/apply-browser-choice= surfaces an error message for a bad plist." - (test-browser-setup) - (let ((received nil)) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq received (apply #'format fmt args))))) - (cj/apply-browser-choice nil)) - (should (string-match-p "Invalid" received))) - (test-browser-teardown)) (ert-deftest test-browser-initialize-wrapper-loaded-branch-applies () "Normal: =cj/initialize-browser= applies the saved browser when one is loaded." diff --git a/tests/test-build-theme.el b/tests/test-build-theme.el index 87b17e0a4..8793da73a 100644 --- a/tests/test-build-theme.el +++ b/tests/test-build-theme.el @@ -1,4 +1,4 @@ -;;; test-build-theme.el --- Tests for the theme.json -> dupre-*.el converter -*- lexical-binding: t -*- +;;; test-build-theme.el --- Tests for the theme.json -> deftheme converter -*- lexical-binding: t -*- ;;; Commentary: @@ -34,12 +34,14 @@ "{ \"name\": \"dupre-fixture\", \"palette\": [[\"#000000\",\"ground\"],[\"#7a9abe\",\"blue\"],[\"#84b068\",\"green\"]], - \"assignments\": { - \"bg\":\"#000000\", \"p\":\"#cdced1\", - \"kw\":\"#7a9abe\", \"str\":\"#84b068\", \"cm\":\"#838d97\", \"dec\":\"#e8bd30\" + \"syntax\": { + \"bg\": {\"fg\":\"#000000\",\"bg\":null,\"bold\":false,\"italic\":false}, + \"p\": {\"fg\":\"#cdced1\",\"bg\":null,\"bold\":false,\"italic\":false}, + \"kw\": {\"fg\":\"#7a9abe\",\"bg\":null,\"bold\":true,\"italic\":false}, + \"str\":{\"fg\":\"#84b068\",\"bg\":null,\"bold\":false,\"italic\":false}, + \"cm\": {\"fg\":\"#838d97\",\"bg\":null,\"bold\":false,\"italic\":true}, + \"dec\":{\"fg\":\"#e8bd30\",\"bg\":null,\"bold\":false,\"italic\":false} }, - \"bold\": [\"kw\"], - \"italic\": [\"cm\"], \"ui\": { \"region\": {\"fg\":null, \"bg\":\"#264364\"}, \"mode-line\": {\"fg\":\"#cdced1\", \"bg\":\"#2f343a\"} @@ -54,8 +56,10 @@ }" "A self-contained theme.json exercising every tier: default, syntax (bold + italic + the unmappable dec key), UI, and packages (a plain face, an -inherit+height face, and a cleared face). Owned by the test so it can't drift -the way Craig's downloaded exports under scripts/theme-studio/ can.") +inherit+height face, and a cleared face). Uses the nested \"syntax\" format the +converter reads -- each category is an object with fg/bg/bold/italic, and bg/p +are themselves category objects carrying fg. Owned by the test so it can't +drift the way Craig's downloaded exports under scripts/theme-studio/ can.") (defun test-build-theme--write-fixture (dir) "Write the fixture JSON into DIR and return its path." @@ -70,7 +74,7 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") (unwind-protect (progn ,@body) (delete-directory ,var t)))) -;; --- WCAG contrast helpers (mirror of the dupre-theme test helpers) --- +;; --- WCAG contrast helpers --- (defun test-build-theme--channel-luminance (c) "Linearize an 8-bit channel value C (0-255) per the WCAG formula." @@ -91,43 +95,175 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") ;;; --------------------------------------------------------------------------- ;;; build-theme/--attrs (the core attribute builder) +;; +;; `--attrs' takes one face-spec alist and emits a face-attribute plist. It +;; reads the full attribute model and tolerates the legacy boolean +;; bold/italic/underline/strike fields that older theme.json exports carry. -(ert-deftest test-build-theme-attrs-fg-and-bold () - "Normal: a foreground plus bold yields :foreground and :weight bold." - (should (equal (build-theme/--attrs nil "#67809c" nil t nil nil nil nil) +;; --- Legacy boolean fields still work (back-compat with committed presets) --- + +(ert-deftest test-build-theme-attrs-legacy-fg-and-bold () + "Normal: legacy bold flag yields :weight bold." + (should (equal (build-theme/--attrs '((fg . "#67809c") (bold . t))) '(:foreground "#67809c" :weight bold)))) -(ert-deftest test-build-theme-attrs-full-ordering () - "Normal: every attribute present, in canonical order." - (should (equal (build-theme/--attrs 'org-level-1 "#e8bd30" "#1a1714" t t t t 1.3) - '(:inherit org-level-1 :foreground "#e8bd30" :background "#1a1714" - :weight bold :slant italic :underline t :strike-through t :height 1.3)))) - -(ert-deftest test-build-theme-attrs-underline-and-strike () - "Normal: underline and strike yield :underline t and :strike-through t." - (should (equal (build-theme/--attrs nil "#67809c" nil nil nil t t nil) - '(:foreground "#67809c" :underline t :strike-through t))) - ;; either alone - (should (equal (build-theme/--attrs nil nil nil nil nil t nil nil) - '(:underline t))) - (should (equal (build-theme/--attrs nil nil nil nil nil nil t nil) - '(:strike-through t)))) +(ert-deftest test-build-theme-attrs-legacy-italic-underline-strike () + "Normal: legacy italic/underline/strike booleans map to their attributes." + (should (equal (build-theme/--attrs '((italic . t))) '(:slant italic))) + (should (equal (build-theme/--attrs '((underline . t))) '(:underline t))) + (should (equal (build-theme/--attrs '((strike . t))) '(:strike-through t)))) (ert-deftest test-build-theme-attrs-empty-is-nil () - "Boundary: a fully-cleared face (all nil) yields an empty plist." - (should (equal (build-theme/--attrs nil nil nil nil nil nil nil nil) '()))) + "Boundary: a blank face (empty alist, or all-nil fields) yields an empty plist." + (should (equal (build-theme/--attrs '()) '())) + (should (equal (build-theme/--attrs '((fg) (bg) (bold) (italic) (underline) (strike))) '()))) (ert-deftest test-build-theme-attrs-bold-false-omits-weight () - "Boundary: bold false produces no :weight key (only overrides are written)." - (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil nil) - '(:foreground "#cdced1")))) + "Boundary: bold false (or absent) writes no :weight -- only overrides appear." + (should (equal (build-theme/--attrs '((fg . "#cdced1") (bold . nil))) + '(:foreground "#cdced1"))) + (should (equal (build-theme/--attrs '((fg . "#cdced1"))) '(:foreground "#cdced1")))) (ert-deftest test-build-theme-attrs-height-one-omitted () - "Boundary: a height of exactly 1.0 is omitted (the default multiplier)." - (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil 1.0) - '(:foreground "#cdced1"))) - (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil 1) - '(:foreground "#cdced1")))) + "Boundary: a height of exactly 1.0 (or integer 1) is omitted as the default." + (should (equal (build-theme/--attrs '((fg . "#cdced1") (height . 1.0))) '(:foreground "#cdced1"))) + (should (equal (build-theme/--attrs '((fg . "#cdced1") (height . 1))) '(:foreground "#cdced1"))) + (should (equal (build-theme/--attrs '((height . 1.2))) '(:height 1.2)))) + +;; --- New attributes --- + +(ert-deftest test-build-theme-attrs-family () + "Normal/Boundary: a non-empty family string emits :family; empty is omitted." + (should (equal (build-theme/--attrs '((family . "Iosevka"))) '(:family "Iosevka"))) + (should (equal (build-theme/--attrs '((family . ""))) '())) + (should (equal (build-theme/--attrs '((family . nil))) '()))) + +(ert-deftest test-build-theme-attrs-distant-foreground () + "Normal: distant-fg emits :distant-foreground." + (should (equal (build-theme/--attrs '((distant-fg . "#ffffff"))) + '(:distant-foreground "#ffffff")))) + +(ert-deftest test-build-theme-attrs-weight-range () + "Normal: an explicit weight string emits that weight symbol." + (should (equal (build-theme/--attrs '((weight . "light"))) '(:weight light))) + (should (equal (build-theme/--attrs '((weight . "semibold"))) '(:weight semibold))) + (should (equal (build-theme/--attrs '((weight . "heavy"))) '(:weight heavy)))) + +(ert-deftest test-build-theme-attrs-weight-overrides-legacy-bold () + "Boundary: an explicit weight wins over a legacy bold flag on the same face." + (should (equal (build-theme/--attrs '((weight . "light") (bold . t))) + '(:weight light)))) + +(ert-deftest test-build-theme-attrs-slant-range () + "Normal: an explicit slant string emits that slant; it wins over legacy italic." + (should (equal (build-theme/--attrs '((slant . "oblique"))) '(:slant oblique))) + (should (equal (build-theme/--attrs '((slant . "normal"))) '(:slant normal))) + (should (equal (build-theme/--attrs '((slant . "oblique") (italic . t))) '(:slant oblique)))) + +(ert-deftest test-build-theme-attrs-underline-object () + "Normal/Boundary: the structured underline form covers line/wave and color." + ;; plain line in the face color collapses to t + (should (equal (build-theme/--attrs '((underline . ((style . "line") (color . nil))))) + '(:underline t))) + ;; wave alone -> a :style plist + (should (equal (build-theme/--attrs '((underline . ((style . "wave") (color . nil))))) + '(:underline (:style wave)))) + ;; colored line -> a :color plist + (should (equal (build-theme/--attrs '((underline . ((style . "line") (color . "#cb6b4d"))))) + '(:underline (:color "#cb6b4d")))) + ;; colored wave -> both + (should (equal (build-theme/--attrs '((underline . ((style . "wave") (color . "#cb6b4d"))))) + '(:underline (:color "#cb6b4d" :style wave))))) + +(ert-deftest test-build-theme-attrs-strike-object () + "Normal: structured strike emits t for no color, or the color string." + (should (equal (build-theme/--attrs '((strike . ((color . nil))))) '(:strike-through t))) + (should (equal (build-theme/--attrs '((strike . ((color . "#cb6b4d"))))) + '(:strike-through "#cb6b4d")))) + +(ert-deftest test-build-theme-attrs-migrated-shapes-match-legacy () + "Boundary: the shapes the import migration produces emit identically to the +legacy booleans they replace, so the cutover keeps generated themes byte-identical. +Mirrors migrateLegacyFace (app-core.js) / migrate_legacy (face_specs.py)." + (should (equal (build-theme/--attrs '((weight . "bold"))) + (build-theme/--attrs '((bold . t))))) + (should (equal (build-theme/--attrs '((slant . "italic"))) + (build-theme/--attrs '((italic . t))))) + (should (equal (build-theme/--attrs '((underline . ((style . "line") (color . nil))))) + (build-theme/--attrs '((underline . t))))) + (should (equal (build-theme/--attrs '((strike . ((color . nil))))) + (build-theme/--attrs '((strike . t)))))) + +(ert-deftest test-build-theme-attrs-overline () + "Normal/Boundary: overline emits t for no color, the color otherwise, nil when unset." + (should (equal (build-theme/--attrs '((overline . ((color . nil))))) '(:overline t))) + (should (equal (build-theme/--attrs '((overline . ((color . "#a9b2bb"))))) + '(:overline "#a9b2bb"))) + (should (equal (build-theme/--attrs '((overline . nil))) '()))) + +(ert-deftest test-build-theme-attrs-inverse-and-extend () + "Normal/Boundary: inverse and extend emit t when set, nothing when nil." + (should (equal (build-theme/--attrs '((inverse . t))) '(:inverse-video t))) + (should (equal (build-theme/--attrs '((extend . t))) '(:extend t))) + (should (equal (build-theme/--attrs '((inverse . t) (extend . t))) + '(:inverse-video t :extend t))) + (should (equal (build-theme/--attrs '((inverse . nil) (extend . nil))) '()))) + +(ert-deftest test-build-theme-attrs-inherit-any-tier () + "Normal: inherit coerces a face-name string to a symbol (now allowed on every tier)." + (should (equal (build-theme/--attrs '((inherit . "shadow"))) '(:inherit shadow))) + (should (equal (build-theme/--attrs '((inherit . shadow))) '(:inherit shadow))) + (should (equal (build-theme/--attrs '((inherit . nil))) '()))) + +(ert-deftest test-build-theme-attrs-full-ordering () + "Normal: every attribute present, emitted in canonical order." + (should (equal (build-theme/--attrs + '((inherit . "org-level-1") (family . "Iosevka") + (fg . "#e8bd30") (bg . "#1a1714") (distant-fg . "#ffffff") + (weight . "semibold") (slant . "italic") (height . 1.3) + (underline . ((style . "wave") (color . "#cb6b4d"))) + (overline . ((color . "#a9b2bb"))) + (strike . ((color . nil))) + (box . ((style . "line") (color . "#67809c"))) + (inverse . t) (extend . t))) + '(:inherit org-level-1 :family "Iosevka" + :foreground "#e8bd30" :background "#1a1714" :distant-foreground "#ffffff" + :weight semibold :slant italic :height 1.3 + :underline (:color "#cb6b4d" :style wave) :overline "#a9b2bb" + :strike-through t :box (:line-width 1 :color "#67809c") + :inverse-video t :extend t)))) + +;; --- Attribute-helper edge cases (the coercion functions in isolation) --- + +(ert-deftest test-build-theme-weight-helper () + "Boundary: weight prefers explicit string, falls back to bold, else nil." + (should (eq (build-theme/--weight '((weight . "bold"))) 'bold)) + (should (eq (build-theme/--weight '((weight . "light") (bold . t))) 'light)) + (should (eq (build-theme/--weight '((bold . t))) 'bold)) + (should (null (build-theme/--weight '((weight . "") (bold . nil))))) + (should (null (build-theme/--weight '())))) + +(ert-deftest test-build-theme-slant-helper () + "Boundary: slant prefers explicit string, falls back to italic, else nil." + (should (eq (build-theme/--slant '((slant . "oblique"))) 'oblique)) + (should (eq (build-theme/--slant '((italic . t))) 'italic)) + (should (null (build-theme/--slant '((slant . ""))))) + (should (null (build-theme/--slant '())))) + +(ert-deftest test-build-theme-underline-helper () + "Boundary: underline coercion across nil / legacy t / structured forms." + (should (null (build-theme/--underline '((underline . nil))))) + (should (eq (build-theme/--underline '((underline . t))) t)) + (should (eq (build-theme/--underline '((underline . ((style . "line") (color . nil))))) t)) + (should (equal (build-theme/--underline '((underline . ((style . "wave"))))) '(:style wave))) + (should (equal (build-theme/--underline '((underline . ((color . "#aa0000"))))) '(:color "#aa0000")))) + +(ert-deftest test-build-theme-line-attr-helper () + "Boundary: the overline/strike coercion: nil / t / {color} forms." + (should (null (build-theme/--line-attr nil))) + (should (eq (build-theme/--line-attr t) t)) + (should (eq (build-theme/--line-attr '((color . nil))) t)) + (should (equal (build-theme/--line-attr '((color . "#abcdef"))) "#abcdef"))) ;;; --------------------------------------------------------------------------- ;;; build-theme/--face-spec (skips empty faces) @@ -145,9 +281,11 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") ;;; Syntax tier (ert-deftest test-build-theme-syntax-keyword-bold () - "Normal: kw maps to font-lock-keyword-face and picks up the bold set." - (let* ((assignments '((kw . "#7a9abe") (str . "#84b068"))) - (specs (build-theme/--syntax-face-specs assignments '(kw) '()))) + "Normal: kw maps to font-lock-keyword-face and carries its bold flag. +Each syntax category is a nested object with fg/bold/italic." + (let* ((syntax '((kw . ((fg . "#7a9abe") (bold . t))) + (str . ((fg . "#84b068"))))) + (specs (build-theme/--syntax-face-specs syntax))) (should (member '(font-lock-keyword-face ((t (:foreground "#7a9abe" :weight bold)))) specs)) (should (member '(font-lock-string-face ((t (:foreground "#84b068")))) @@ -155,7 +293,7 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") (ert-deftest test-build-theme-syntax-one-to-many () "Normal: punc fans out to every punctuation/bracket/delimiter face." - (let ((specs (build-theme/--syntax-face-specs '((punc . "#a9b2bb")) '() '()))) + (let ((specs (build-theme/--syntax-face-specs '((punc . ((fg . "#a9b2bb"))))))) (dolist (face '(font-lock-punctuation-face font-lock-bracket-face font-lock-delimiter-face font-lock-misc-punctuation-face)) (should (member `(,face ((t (:foreground "#a9b2bb")))) specs))))) @@ -164,12 +302,12 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") "Boundary: dec has no independent Emacs face, so it maps to nothing. Emacs renders decorators with font-lock-type-face, which ty already owns; mapping dec would clobber the type color." - (let ((specs (build-theme/--syntax-face-specs '((dec . "#e8bd30")) '() '()))) + (let ((specs (build-theme/--syntax-face-specs '((dec . ((fg . "#e8bd30"))))))) (should (null specs)))) (ert-deftest test-build-theme-syntax-comment-italic () - "Normal: cm in the italic set yields :slant italic on the comment face." - (let ((specs (build-theme/--syntax-face-specs '((cm . "#a9b2bb")) '() '(cm)))) + "Normal: cm with its italic flag yields :slant italic on the comment face." + (let ((specs (build-theme/--syntax-face-specs '((cm . ((fg . "#a9b2bb") (italic . t))))))) (should (member '(font-lock-comment-face ((t (:foreground "#a9b2bb" :slant italic)))) specs)))) @@ -177,8 +315,9 @@ mapping dec would clobber the type color." ;;; Default face (ert-deftest test-build-theme-default-face () - "Normal: default takes background from bg and foreground from p." - (should (equal (build-theme/--default-spec '((bg . "#000000") (p . "#cdced1"))) + "Normal: default takes background from syntax.bg.fg and foreground from syntax.p.fg." + (should (equal (build-theme/--default-spec '((bg . ((fg . "#000000"))) + (p . ((fg . "#cdced1"))))) '(default ((t (:foreground "#cdced1" :background "#000000"))))))) ;;; --------------------------------------------------------------------------- @@ -294,7 +433,7 @@ including an inherit+height package face." (ert-deftest test-build-theme-convert-file-old-json-without-packages () "Boundary: a theme.json with no packages key still converts and loads." (test-build-theme--with-sandbox out - (let* ((json "{\"name\":\"noformat\",\"palette\":[[\"#000000\",\"ground\"]],\"assignments\":{\"bg\":\"#000000\",\"p\":\"#ffffff\",\"kw\":\"#67809c\"},\"bold\":[\"kw\"],\"italic\":[],\"ui\":{}}") + (let* ((json "{\"name\":\"noformat\",\"palette\":[[\"#000000\",\"ground\"]],\"syntax\":{\"bg\":{\"fg\":\"#000000\"},\"p\":{\"fg\":\"#ffffff\"},\"kw\":{\"fg\":\"#67809c\",\"bold\":true}},\"ui\":{}}") (in (expand-file-name "noformat.json" out))) (with-temp-file in (insert json)) (let ((path (build-theme/convert-file in out))) @@ -313,6 +452,25 @@ including an inherit+height package face." (test-build-theme--with-sandbox out (should-error (build-theme/convert-file (expand-file-name "does-not-exist.json" out) out)))) +(ert-deftest test-build-theme-name-from-filename-not-json-field () + "Normal/Regression: the output name comes from the JSON file's basename, not +its internal name field, so each draft exports under its own name (a WIP.json +becomes WIP-theme.el, never theme-theme.el)." + (test-build-theme--with-sandbox out + ;; The fixture's internal name field is \"dupre-fixture\"; the file is sterling.json. + (let ((in (expand-file-name "sterling.json" out))) + (with-temp-file in (insert test-build-theme--fixture-json)) + (let ((path (build-theme/convert-file in out))) + (should (string-suffix-p "sterling-theme.el" path)) + (should-not (string-match-p "dupre-fixture" path)) + (let ((custom-theme-load-path (cons out custom-theme-load-path)) + (load-path (cons out load-path))) + (unwind-protect + (progn + (load-theme 'sterling t) + (should (string= (face-attribute 'default :background nil t) "#000000"))) + (disable-theme 'sterling))))))) + (ert-deftest test-build-theme-generated-default-meets-wcag-aa () "Error/Regression: the generated default face stays legible. A WCAG-AA (>= 4.5:1) assertion on the round-tripped result -- proves the whole @@ -329,5 +487,46 @@ parse -> spec -> file -> face pipeline preserves the designed contrast." (should (>= (test-build-theme--contrast fg bg) 4.5)))) (disable-theme 'dupre-fixture)))))) +(ert-deftest test-build-theme-convert-file-new-attributes-round-trip () + "Integration: the new attribute model survives parse -> spec -> file -> face. +Components integrated: +- build-theme/convert-file (entry point, real) +- json parsing of the inline fixture (real) +- custom-theme-set-faces / load-theme / face-attribute (real) +Exercises extend, structured underline (wave + color), overline, inverse-video, +distant-foreground, family, and the weight/slant ranges across the UI and +package tiers." + (test-build-theme--with-sandbox out + (let* ((json "{\"name\":\"newattrs\",\"palette\":[[\"#000000\",\"ground\"]], + \"syntax\":{\"bg\":{\"fg\":\"#000000\"},\"p\":{\"fg\":\"#ffffff\"}}, + \"ui\":{ + \"region\":{\"bg\":\"#264364\",\"extend\":true}, + \"highlight\":{\"fg\":\"#eddba7\",\"underline\":{\"style\":\"wave\",\"color\":\"#cb6b4d\"},\"overline\":{\"color\":\"#a9b2bb\"}}, + \"secondary-selection\":{\"bg\":\"#333333\",\"inverse\":true,\"distant-fg\":\"#ffffff\"} + }, + \"packages\":{ + \"misc\":{ + \"shadow\":{\"fg\":\"#cdced1\",\"family\":\"Iosevka\",\"weight\":\"light\",\"slant\":\"oblique\",\"source\":\"user\"} + } + }}") + (in (expand-file-name "newattrs.json" out))) + (with-temp-file in (insert json)) + (build-theme/convert-file in out) + (let ((custom-theme-load-path (cons out custom-theme-load-path)) + (load-path (cons out load-path))) + (unwind-protect + (progn + (load-theme 'newattrs t) + (should (eq (face-attribute 'region :extend nil t) t)) + (should (equal (face-attribute 'highlight :underline nil t) + '(:color "#cb6b4d" :style wave))) + (should (string= (face-attribute 'highlight :overline nil t) "#a9b2bb")) + (should (eq (face-attribute 'secondary-selection :inverse-video nil t) t)) + (should (string= (face-attribute 'secondary-selection :distant-foreground nil t) "#ffffff")) + (should (string= (face-attribute 'shadow :family nil t) "Iosevka")) + (should (eq (face-attribute 'shadow :weight nil t) 'light)) + (should (eq (face-attribute 'shadow :slant nil t) 'oblique))) + (disable-theme 'newattrs)))))) + (provide 'test-build-theme) ;;; test-build-theme.el ends here diff --git a/tests/test-calendar-sync--apply-single-exception.el b/tests/test-calendar-sync--apply-single-exception.el index 2fcf7c718..3d2342708 100644 --- a/tests/test-calendar-sync--apply-single-exception.el +++ b/tests/test-calendar-sync--apply-single-exception.el @@ -63,5 +63,47 @@ (let ((result (calendar-sync--apply-single-exception occ exc))) (should (equal "Keep" (plist-get result :summary)))))) +;;; Normal Cases — remaining overridable fields + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-description () + "Normal: an exception :description overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :description "old")) + (exc (list :start '(2026 3 15 14 0) :description "new"))) + (should (equal "new" + (plist-get (calendar-sync--apply-single-exception occ exc) + :description))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-location () + "Normal: an exception :location overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :location "Room A")) + (exc (list :start '(2026 3 15 14 0) :location "Room B"))) + (should (equal "Room B" + (plist-get (calendar-sync--apply-single-exception occ exc) + :location))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-attendees () + "Normal: an exception :attendees overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :attendees '("a"))) + (exc (list :start '(2026 3 15 14 0) :attendees '("b" "c")))) + (should (equal '("b" "c") + (plist-get (calendar-sync--apply-single-exception occ exc) + :attendees))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-organizer () + "Normal: an exception :organizer overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :organizer "old@x")) + (exc (list :start '(2026 3 15 14 0) :organizer "new@x"))) + (should (equal "new@x" + (plist-get (calendar-sync--apply-single-exception occ exc) + :organizer))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-url () + "Normal: an exception :url overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :url "http://old")) + (exc (list :start '(2026 3 15 14 0) :url "http://new"))) + (should (equal "http://new" + (plist-get (calendar-sync--apply-single-exception occ exc) + :url))))) + (provide 'test-calendar-sync--apply-single-exception) ;;; test-calendar-sync--apply-single-exception.el ends here diff --git a/tests/test-calendar-sync--expand-recurring-event.el b/tests/test-calendar-sync--expand-recurring-event.el new file mode 100644 index 000000000..41f0afa9c --- /dev/null +++ b/tests/test-calendar-sync--expand-recurring-event.el @@ -0,0 +1,106 @@ +;;; test-calendar-sync--expand-recurring-event.el --- Tests for recurrence dispatch -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for calendar-sync--expand-recurring-event — the dispatcher that maps +;; an RRULE frequency to the matching expander and applies EXDATE filtering. +;; The individual expanders, parser, and exdate helpers have their own tests; +;; here they are stubbed at the boundary so only the dispatch and the +;; exdate-vs-no-exdate branch are exercised. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'testutil-calendar-sync) +(require 'calendar-sync) + +(defmacro test-cs-ere--with (overrides &rest body) + "Run BODY with the recurrence helpers stubbed. +OVERRIDES is an extra list of cl-letf* bindings layered on the defaults: +RRULE present, parse-event returns 'BASE, no exdates, and every expander +errors if called (each test re-binds the one it expects). cl-letf* is +sequential, so a re-bound place in OVERRIDES wins over the default." + (declare (indent 1)) + `(cl-letf* (((symbol-function 'calendar-sync--get-property) + (lambda (_e prop) (when (string= prop "RRULE") "R"))) + ((symbol-function 'calendar-sync--parse-event) (lambda (_e) 'BASE)) + ((symbol-function 'calendar-sync--collect-exdates) (lambda (_e) nil)) + ((symbol-function 'calendar-sync--expand-daily) + (lambda (&rest _) (error "daily should not be called"))) + ((symbol-function 'calendar-sync--expand-weekly) + (lambda (&rest _) (error "weekly should not be called"))) + ((symbol-function 'calendar-sync--expand-monthly) + (lambda (&rest _) (error "monthly should not be called"))) + ((symbol-function 'calendar-sync--expand-yearly) + (lambda (&rest _) (error "yearly should not be called"))) + ((symbol-function 'calendar-sync--filter-exdates) + (lambda (&rest _) (error "filter-exdates should not be called"))) + ,@overrides) + ,@body)) + +;;; Normal Cases — frequency dispatch + +(ert-deftest test-calendar-sync--expand-recurring-event-dispatches-daily () + "Normal: FREQ=DAILY routes to the daily expander." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--expand-daily) (lambda (&rest _) '(DAILY)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(DAILY))))) + +(ert-deftest test-calendar-sync--expand-recurring-event-dispatches-monthly () + "Normal: FREQ=MONTHLY routes to the monthly expander." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq monthly))) + ((symbol-function 'calendar-sync--expand-monthly) (lambda (&rest _) '(MONTHLY)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(MONTHLY))))) + +(ert-deftest test-calendar-sync--expand-recurring-event-dispatches-yearly () + "Normal: FREQ=YEARLY routes to the yearly expander." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq yearly))) + ((symbol-function 'calendar-sync--expand-yearly) (lambda (&rest _) '(YEARLY)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(YEARLY))))) + +;;; Boundary / Error Cases + +(ert-deftest test-calendar-sync--expand-recurring-event-unsupported-freq-nil () + "Error: an unsupported frequency expands to nil, no expander called." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq hourly)))) + (should-not (calendar-sync--expand-recurring-event "evt" 'range)))) + +(ert-deftest test-calendar-sync--expand-recurring-event-no-rrule-nil () + "Boundary: an event with no RRULE returns nil (not a recurring event)." + (test-cs-ere--with + (((symbol-function 'calendar-sync--get-property) (lambda (&rest _) nil))) + (should-not (calendar-sync--expand-recurring-event "evt" 'range)))) + +(ert-deftest test-calendar-sync--expand-recurring-event-unparseable-base-nil () + "Boundary: when the base event fails to parse, expansion returns nil." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--parse-event) (lambda (_e) nil))) + (should-not (calendar-sync--expand-recurring-event "evt" 'range)))) + +;;; EXDATE branch + +(ert-deftest test-calendar-sync--expand-recurring-event-applies-exdate-filter () + "Normal: with exdates present, occurrences pass through the exdate filter." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--expand-daily) (lambda (&rest _) '(O1 O2))) + ((symbol-function 'calendar-sync--collect-exdates) (lambda (_e) '(EX))) + ((symbol-function 'calendar-sync--filter-exdates) + (lambda (occs _ex) (remq 'O2 occs)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(O1))))) + +(ert-deftest test-calendar-sync--expand-recurring-event-no-exdate-skips-filter () + "Boundary: with no exdates, the filter is skipped and occurrences pass through." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--expand-daily) (lambda (&rest _) '(O1 O2)))) + ;; filter-exdates stays the error stub; it must not be called here + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(O1 O2))))) + +(provide 'test-calendar-sync--expand-recurring-event) +;;; test-calendar-sync--expand-recurring-event.el ends here diff --git a/tests/test-calendar-sync--get-all-property-lines.el b/tests/test-calendar-sync--get-all-property-lines.el index c95041c9a..737d2af0d 100644 --- a/tests/test-calendar-sync--get-all-property-lines.el +++ b/tests/test-calendar-sync--get-all-property-lines.el @@ -57,5 +57,23 @@ "Test empty event string returns nil." (should (null (calendar-sync--get-all-property-lines "" "ATTENDEE")))) +;;; Boundary Cases — position advancement + +(ert-deftest test-calendar-sync--get-all-property-lines-property-at-end-no-newline () + "Boundary: a match at end of string with no trailing newline still returns it. +Exercises the end-equals-length branch of position advancement." + (let ((result (calendar-sync--get-all-property-lines + "ATTENDEE:foo@example.com" "ATTENDEE"))) + (should (= 1 (length result))) + (should (string-match-p "foo@example.com" (car result))))) + +(ert-deftest test-calendar-sync--get-all-property-lines-second-match-after-continuation () + "Boundary: a first match with a continuation does not hide the second match." + (let ((result (calendar-sync--get-all-property-lines + "ATTENDEE:a\n more\nATTENDEE:b\nSUMMARY:x" "ATTENDEE"))) + (should (= 2 (length result))) + (should (string-match-p "more" (nth 0 result))) + (should (string-match-p "ATTENDEE:b" (nth 1 result))))) + (provide 'test-calendar-sync--get-all-property-lines) ;;; test-calendar-sync--get-all-property-lines.el ends here diff --git a/tests/test-calendar-sync--parse-exception-event.el b/tests/test-calendar-sync--parse-exception-event.el new file mode 100644 index 000000000..1935d3ebb --- /dev/null +++ b/tests/test-calendar-sync--parse-exception-event.el @@ -0,0 +1,64 @@ +;;; test-calendar-sync--parse-exception-event.el --- Tests for one-event exception parsing -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for calendar-sync--parse-exception-event, the per-VEVENT half of +;; calendar-sync--collect-recurrence-exceptions: it turns a single RECURRENCE-ID +;; override VEVENT into an exception plist (or nil). One function per file. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "." (file-name-directory load-file-name))) +(add-to-list 'load-path (expand-file-name "../modules" (file-name-directory load-file-name))) +(require 'testutil-calendar-sync) +(require 'calendar-sync) + +(defun test-cs-parse-exc--override-event (start end) + "Return a RECURRENCE-ID override VEVENT string for START..END." + (concat "BEGIN:VEVENT\n" + "UID:override@google.com\n" + "RECURRENCE-ID:20260203T090000Z\n" + "SUMMARY:Rescheduled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "DTEND:" (test-calendar-sync-ics-datetime end) "\n" + "END:VEVENT")) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--parse-exception-event-normal-returns-plist () + "Normal: a RECURRENCE-ID override parses into a plist with its overridden times." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (plist (calendar-sync--parse-exception-event + (test-cs-parse-exc--override-event start end)))) + (should plist) + (should (plist-get plist :recurrence-id)) + (should (equal "20260203T090000Z" (plist-get plist :recurrence-id-raw))) + (should (plist-get plist :start)) + (should (plist-get plist :end)) + (should (equal "Rescheduled Meeting" (plist-get plist :summary))))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--parse-exception-event-boundary-no-recurrence-id () + "Boundary: a VEVENT with no RECURRENCE-ID is not an override and returns nil." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (event (test-calendar-sync-make-vevent "Regular Event" start end))) + (should-not (calendar-sync--parse-exception-event event)))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--parse-exception-event-error-unparseable-times () + "Error: a RECURRENCE-ID override whose times do not parse returns nil rather +than a half-built plist." + (let ((event (concat "BEGIN:VEVENT\n" + "UID:broken@google.com\n" + "RECURRENCE-ID:not-a-timestamp\n" + "SUMMARY:Broken Override\n" + "DTSTART:also-garbage\n" + "END:VEVENT"))) + (should-not (calendar-sync--parse-exception-event event)))) + +(provide 'test-calendar-sync--parse-exception-event) +;;; test-calendar-sync--parse-exception-event.el ends here diff --git a/tests/test-calendar-sync--parse-timestamp.el b/tests/test-calendar-sync--parse-timestamp.el index d05540f7c..6a56ba9e2 100644 --- a/tests/test-calendar-sync--parse-timestamp.el +++ b/tests/test-calendar-sync--parse-timestamp.el @@ -55,5 +55,28 @@ "Truncated datetime returns nil." (should (null (calendar-sync--parse-timestamp "2026031")))) +;;; Boundary / Error — second capture, TZID fallback, leap day + +(ert-deftest test-calendar-sync--parse-timestamp-utc-passes-nonzero-seconds () + "Boundary: the seconds field is captured and passed to the UTC converter." + (cl-letf (((symbol-function 'calendar-sync--convert-utc-to-local) + (lambda (y mo d h mi s) (list 'utc y mo d h mi s)))) + (should (equal (calendar-sync--parse-timestamp "20260315T180045Z") + '(utc 2026 3 15 18 0 45))))) + +(ert-deftest test-calendar-sync--parse-timestamp-tzid-fallback-on-failure () + "Error: when TZID conversion fails, the raw 5-tuple is returned." + (cl-letf (((symbol-function 'calendar-sync--convert-tz-to-local) + (lambda (&rest _) nil))) + (should (equal (calendar-sync--parse-timestamp "20260315T180000" "Fake/Zone") + '(2026 3 15 18 0))))) + +(ert-deftest test-calendar-sync--parse-timestamp-leap-day-components () + "Boundary: a valid leap day (2024-02-29) is parsed into its components." + (cl-letf (((symbol-function 'calendar-sync--convert-utc-to-local) + (lambda (y mo d h mi s) (list y mo d h mi s)))) + (should (equal (calendar-sync--parse-timestamp "20240229T120000Z") + '(2024 2 29 12 0 0))))) + (provide 'test-calendar-sync--parse-timestamp) ;;; test-calendar-sync--parse-timestamp.el ends here diff --git a/tests/test-calendar-sync.el b/tests/test-calendar-sync.el index b912c1328..62b00aba1 100644 --- a/tests/test-calendar-sync.el +++ b/tests/test-calendar-sync.el @@ -693,5 +693,22 @@ Valid events should be parsed, invalid ones skipped." (should retrieved) (should (eq 'ok (plist-get retrieved :status)))))) +;;; Tests: calendar-sync--parse-ics — boundary inputs + +(ert-deftest test-calendar-sync--parse-ics-nil-content-returns-nil () + "Boundary: nil ICS content is handled gracefully and returns nil." + (should (null (calendar-sync--parse-ics nil)))) + +(ert-deftest test-calendar-sync--parse-ics-drops-out-of-range-event () + "Boundary: a non-recurring event outside the date range is dropped." + (let* ((far (test-calendar-sync-make-vevent + "OutOfRangeEvent" + (test-calendar-sync-time-days-from-now 3650 10 0) + (test-calendar-sync-time-days-from-now 3650 11 0))) + (ics (test-calendar-sync-make-ics far)) + (org-content (calendar-sync--parse-ics ics))) + (should-not (and org-content + (string-match-p "OutOfRangeEvent" org-content))))) + (provide 'test-calendar-sync) ;;; test-calendar-sync.el ends here diff --git a/tests/test-chrono-tools--sound-helpers.el b/tests/test-chrono-tools--sound-helpers.el new file mode 100644 index 000000000..08f71f9bb --- /dev/null +++ b/tests/test-chrono-tools--sound-helpers.el @@ -0,0 +1,54 @@ +;;; test-chrono-tools--sound-helpers.el --- Tests for the tmr sound-file helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/tmr--current-sound-name and cj/tmr--apply-sound-file were extracted from +;; the deeply-nested cj/tmr-select-sound-file so the "what's the current sound" +;; and "set the chosen sound" steps are unit-testable apart from the +;; completing-read UI. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'chrono-tools) + +(defvar tmr-sound-file) +(defvar sounds-dir) +(defvar notification-sound) + +(ert-deftest test-chrono-current-sound-name-existing () + "Normal: returns the basename when the current sound file exists." + (let* ((f (make-temp-file "tmr-sound" nil ".wav")) + (tmr-sound-file f)) + (unwind-protect + (should (equal (cj/tmr--current-sound-name) (file-name-nondirectory f))) + (delete-file f)))) + +(ert-deftest test-chrono-current-sound-name-missing-or-nil () + "Boundary: a missing file or nil yields nil." + (let ((tmr-sound-file "/no/such/file.wav")) + (should (null (cj/tmr--current-sound-name)))) + (let ((tmr-sound-file nil)) + (should (null (cj/tmr--current-sound-name))))) + +(ert-deftest test-chrono-apply-sound-file-sets-and-messages () + "Normal: sets tmr-sound-file under sounds-dir and reports the choice." + (let ((sounds-dir "/snd") + (notification-sound "/snd/default.wav") + (tmr-sound-file nil)) + (let ((msg (cj/tmr--apply-sound-file "chime.wav"))) + (should (equal tmr-sound-file "/snd/chime.wav")) + (should (string-match-p "Timer sound set to: chime.wav" msg))))) + +(ert-deftest test-chrono-apply-sound-file-default-branch () + "Boundary: choosing the notification sound reports it as the default." + (let ((sounds-dir "/snd") + (notification-sound "/snd/default.wav") + (tmr-sound-file nil)) + (let ((msg (cj/tmr--apply-sound-file "default.wav"))) + (should (equal tmr-sound-file "/snd/default.wav")) + (should (string-match-p "default: default.wav" msg))))) + +(provide 'test-chrono-tools--sound-helpers) +;;; test-chrono-tools--sound-helpers.el ends here diff --git a/tests/test-cj-cache-lib.el b/tests/test-cj-cache-lib.el index aeb329dda..7de7edb8c 100644 --- a/tests/test-cj-cache-lib.el +++ b/tests/test-cj-cache-lib.el @@ -4,7 +4,7 @@ ;; Unit tests for the TTL+building cache helper. Covers cache-make / ;; cache-valid-p / cache-value-or-rebuild / cache-building-p / ;; cache-invalidate against the contract in -;; docs/design/cache-helper-design.org. +;; docs/specs/cache-helper-design-spec-implemented.org. ;;; Code: diff --git a/tests/test-cj-window-geometry-lib.el b/tests/test-cj-window-geometry-lib.el index 05ed95950..d32a48a92 100644 --- a/tests/test-cj-window-geometry-lib.el +++ b/tests/test-cj-window-geometry-lib.el @@ -2,7 +2,7 @@ ;;; Commentary: ;; Tests the pure helpers in `cj-window-geometry-lib.el': -;; `cj/window-direction', `cj/window-body-size', +;; `cj/window-direction', `cj/window-replay-size', ;; `cj/cardinal-to-edge-direction', and `cj/window-at-edge'. ;;; Code: @@ -52,30 +52,32 @@ (delete-other-windows) (should (eq (cj/window-direction (selected-window) 'below) 'below)))) -(ert-deftest test-cj-window-geometry--body-size-right-returns-body-cols () +(ert-deftest test-cj-window-geometry--replay-size-right-returns-body-cols () "Normal: right window with direction='right -> body-width in cols." (save-window-excursion (delete-other-windows) (let ((right (split-window (selected-window) nil 'right))) - (should (= (cj/window-body-size right 'right) + (should (= (cj/window-replay-size right 'right) (window-body-width right)))))) -(ert-deftest test-cj-window-geometry--body-size-below-returns-body-lines () - "Normal: below window with direction='below -> body-height in lines." +(ert-deftest test-cj-window-geometry--replay-size-below-returns-total-lines () + "Normal: below window with direction='below -> total-height in lines. +The vertical axis captures total-height (not body-height) so the capture/ +replay round-trip is immune to the mode line's pixel height." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below))) - (should (= (cj/window-body-size below 'below) - (window-body-height below)))))) + (should (= (cj/window-replay-size below 'below) + (window-total-height below)))))) -(ert-deftest test-cj-window-geometry--body-size-narrow-window () +(ert-deftest test-cj-window-geometry--replay-size-narrow-window () "Normal: deliberately narrow right window -> matching body cols." (save-window-excursion (delete-other-windows) (let* ((frame-w (frame-width)) (target-cols (/ frame-w 4)) (right (split-window (selected-window) (- target-cols) 'right))) - (should (= (cj/window-body-size right 'right) + (should (= (cj/window-replay-size right 'right) (window-body-width right)))))) (ert-deftest test-cj-window-geometry--cardinal-to-edge-right () @@ -197,5 +199,52 @@ window forms the full-height right half -> nil." (should (null (cj/window-size-fraction nil 40))) (should (null (cj/window-size-fraction 20 nil)))) +;; ----------------------------- preferred-dock-direction ----------------------------- + +(ert-deftest test-cj-window-geometry-dock-wide-frame-is-right () + "Normal: a frame wide enough for both panes to clear 80 docks right." + (should (eq (cj/preferred-dock-direction 200 0.5) 'right))) + +(ert-deftest test-cj-window-geometry-dock-narrow-frame-is-below () + "Normal: an 0.5 split on a 138-col frame leaves ~68-col panes -> below." + (should (eq (cj/preferred-dock-direction 138 0.5) 'below))) + +(ert-deftest test-cj-window-geometry-dock-boundary-exactly-min-is-right () + "Boundary: when the narrower pane lands exactly on 80, dock right." + ;; 161 cols, 0.5: panel 80, main 161-80-1 = 80, narrower 80 -> right. + (should (eq (cj/preferred-dock-direction 161 0.5) 'right))) + +(ert-deftest test-cj-window-geometry-dock-boundary-one-under-min-is-below () + "Boundary: one column short of the floor stacks instead." + ;; 160 cols, 0.5: panel 80, main 160-80-1 = 79, narrower 79 -> below. + (should (eq (cj/preferred-dock-direction 160 0.5) 'below))) + +(ert-deftest test-cj-window-geometry-dock-narrow-panel-fraction-governs () + "Normal: a slim panel fraction makes the panel the narrower pane." + ;; 200 cols, 0.3: panel 60 < 80 -> below, even though main (139) is wide. + (should (eq (cj/preferred-dock-direction 200 0.3) 'below)) + ;; 300 cols, 0.3: panel 90, main 209 -> right. + (should (eq (cj/preferred-dock-direction 300 0.3) 'right))) + +(ert-deftest test-cj-window-geometry-dock-honors-explicit-min-cols () + "Boundary: an explicit MIN-COLS overrides the default floor." + ;; 138 cols, 0.5 -> ~68-col panes: passes a 60-floor, fails the 80-default. + (should (eq (cj/preferred-dock-direction 138 0.5 60) 'right)) + (should (eq (cj/preferred-dock-direction 138 0.5 80) 'below))) + +(ert-deftest test-cj-window-geometry-dock-honors-custom-default-var () + "Boundary: the default floor reads `cj/window-dock-min-columns'." + (let ((cj/window-dock-min-columns 30)) + (should (eq (cj/preferred-dock-direction 138 0.5) 'right)))) + +(ert-deftest test-cj-window-geometry-dock-degenerate-input-is-below () + "Error: non-positive cols or out-of-range fraction stacks (safe fallback)." + (should (eq (cj/preferred-dock-direction 0 0.5) 'below)) + (should (eq (cj/preferred-dock-direction -10 0.5) 'below)) + (should (eq (cj/preferred-dock-direction 200 0) 'below)) + (should (eq (cj/preferred-dock-direction 200 1) 'below)) + (should (eq (cj/preferred-dock-direction nil 0.5) 'below)) + (should (eq (cj/preferred-dock-direction 200 nil) 'below))) + (provide 'test-cj-window-geometry-lib) ;;; test-cj-window-geometry-lib.el ends here diff --git a/tests/test-cj-window-toggle-lib.el b/tests/test-cj-window-toggle-lib.el index 0762e255c..5edd06e96 100644 --- a/tests/test-cj-window-toggle-lib.el +++ b/tests/test-cj-window-toggle-lib.el @@ -36,7 +36,9 @@ (window-body-width right)))))) (ert-deftest test-cj-window-toggle-capture-records-below-split () - "Normal: below-split window writes direction=below and integer body-lines." + "Normal: below-split window writes direction=below and integer total-lines. +The vertical axis captures total-height, not body-height, so the round-trip +is immune to the mode line's pixel height (see `cj/window-replay-size')." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below)) @@ -49,7 +51,7 @@ (should (eq test-cj-window-toggle--last-direction 'below)) (should (integerp test-cj-window-toggle--last-size)) (should (= test-cj-window-toggle--last-size - (window-body-height below)))))) + (window-total-height below)))))) (ert-deftest test-cj-window-toggle-capture-falls-back-to-default-direction () "Boundary: window filling the frame uses the supplied default direction." @@ -156,7 +158,9 @@ transfer; clearing it lets the consumer's default size apply." (should (eq (cdr (assq 'inhibit-same-window received-alist)) t)))) (ert-deftest test-cj-window-toggle-display-saved-maps-below-to-bottom () - "Normal: saved below + integer size -> bottom edge, body-lines cons." + "Normal: saved below + integer size -> bottom edge, plain total-line count. +The height axis replays a total-line integer (not a body-lines cons) so the +round-trip is immune to the mode line's pixel height." (let (received-alist (test-cj-window-toggle--last-direction 'below) (test-cj-window-toggle--last-size 12)) @@ -169,8 +173,7 @@ transfer; clearing it lets the consumer's default size apply." 'test-cj-window-toggle--last-size 0.7)) (should (eq (cdr (assq 'direction received-alist)) 'bottom)) - (should (equal (cdr (assq 'window-height received-alist)) - '(body-lines . 12))) + (should (equal (cdr (assq 'window-height received-alist)) 12)) (should-not (assq 'window-width received-alist)))) (ert-deftest test-cj-window-toggle-display-saved-maps-right-to-rightmost () diff --git a/tests/test-coverage-core--changed-lines.el b/tests/test-coverage-core--changed-lines.el index f271fde15..0662594b4 100644 --- a/tests/test-coverage-core--changed-lines.el +++ b/tests/test-coverage-core--changed-lines.el @@ -227,5 +227,106 @@ Binary files a/image.png and b/image.png differ (should-error (cj/--coverage-changed-lines 'bogus-scope) :type 'user-error)) +;;; Boundary cases — parser, /dev/null and orphan hunks + +(ert-deftest test-coverage-parse-diff-dev-null-resets-current-file () + "Boundary: a \"+++ /dev/null\" target resets state so a following hunk is +not misattributed to the previous file." + (let* ((input (concat "diff --git a/keep.el b/keep.el\n" + "--- a/keep.el\n" + "+++ b/keep.el\n" + "@@ -1,0 +1,2 @@\n" + "+k1\n+k2\n" + "diff --git a/gone.el b/gone.el\n" + "--- a/gone.el\n" + "+++ /dev/null\n" + "@@ -1,0 +5,2 @@\n" + "+orphan1\n+orphan2\n")) + (result (cj/--coverage-parse-diff-output input)) + (keep (gethash "keep.el" result))) + (should (= 1 (hash-table-count result))) ; gone.el never recorded + (should (= 2 (hash-table-count keep))) + (should (gethash 1 keep)) + (should (gethash 2 keep)) + (should-not (gethash 5 keep)) ; not misattributed + (should-not (gethash 6 keep)))) + +(ert-deftest test-coverage-parse-diff-hunk-before-any-file-marker () + "Boundary: a hunk header before any file marker is ignored, not crashed on." + (let* ((input (concat "@@ -1,0 +1,2 @@\n" + "+orphan1\n+orphan2\n" + "diff --git a/real.el b/real.el\n" + "--- a/real.el\n" + "+++ b/real.el\n" + "@@ -1,0 +1,1 @@\n" + "+r1\n")) + (result (cj/--coverage-parse-diff-output input)) + (real (gethash "real.el" result))) + (should (= 1 (hash-table-count result))) + (should (= 1 (hash-table-count real))) + (should (gethash 1 real)))) + +;;; merge-base (stubbed git invocation) + +(ert-deftest test-coverage-git-merge-base-returns-trimmed-sha () + "Normal: a SHA with trailing newline is trimmed and returned." + (cl-letf (((symbol-function 'process-file) + (lambda (_program _infile destination _display &rest _args) + (with-current-buffer destination (insert "abc123\n")) + 0))) + (should (equal (cj/--coverage-git-merge-base "main") "abc123")))) + +(ert-deftest test-coverage-git-merge-base-empty-output-errors () + "Error: empty merge-base output signals user-error (no common commit)." + (cl-letf (((symbol-function 'process-file) + (lambda (_program _infile destination _display &rest _args) + (with-current-buffer destination (insert "")) + 0))) + (should-error (cj/--coverage-git-merge-base "main") :type 'user-error))) + +(ert-deftest test-coverage-git-merge-base-whitespace-output-errors () + "Error: whitespace-only output trims to empty and signals user-error." + (cl-letf (((symbol-function 'process-file) + (lambda (_program _infile destination _display &rest _args) + (with-current-buffer destination (insert " \n")) + 0))) + (should-error (cj/--coverage-git-merge-base "main") :type 'user-error))) + +;;; changed-lines — remaining scopes (stubbed git invocation) + +(ert-deftest test-coverage-changed-lines-staged-stubbed () + "Normal: staged scope invokes git diff --cached via argv." + (let (seen-calls) + (cl-letf (((symbol-function 'process-file) + (lambda (program _infile destination _display &rest args) + (push (cons program args) seen-calls) + (with-current-buffer destination + (insert test-coverage-diff--simple-single-file)) + 0))) + (let ((result (cj/--coverage-changed-lines 'staged))) + (should (equal (nreverse seen-calls) + '(("git" "diff" "--cached" "--unified=0")))) + (should (= 3 (hash-table-count (gethash "foo.el" result)))))))) + +(ert-deftest test-coverage-changed-lines-branch-vs-main-stubbed () + "Normal: branch-vs-main computes merge-base against main, then diffs." + (let (seen-calls) + (cl-letf (((symbol-function 'process-file) + (lambda (program _infile destination _display &rest args) + (push (cons program args) seen-calls) + (with-current-buffer destination + (insert + (pcase args + (`("merge-base" "HEAD" "main") "abc123\n") + (`("diff" "abc123..HEAD" "--unified=0") + test-coverage-diff--simple-single-file) + (_ "")))) + 0))) + (let ((result (cj/--coverage-changed-lines 'branch-vs-main))) + (should (equal (nreverse seen-calls) + '(("git" "merge-base" "HEAD" "main") + ("git" "diff" "abc123..HEAD" "--unified=0")))) + (should (= 3 (hash-table-count (gethash "foo.el" result)))))))) + (provide 'test-coverage-core--changed-lines) ;;; test-coverage-core--changed-lines.el ends here diff --git a/tests/test-coverage-core--project-root.el b/tests/test-coverage-core--project-root.el new file mode 100644 index 000000000..9d596217a --- /dev/null +++ b/tests/test-coverage-core--project-root.el @@ -0,0 +1,37 @@ +;;; test-coverage-core--project-root.el --- Tests for cj/--coverage-project-root -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `cj/--coverage-project-root' in coverage-core.el — returns the +;; projectile project root when available, else `default-directory'. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'coverage-core) + +;;; Normal Cases + +(ert-deftest test-coverage-project-root-uses-projectile-when-available () + "Normal: with projectile available and in a project, returns its root." + (cl-letf (((symbol-function 'projectile-project-root) + (lambda () "/home/u/proj/"))) + (should (equal (cj/--coverage-project-root) "/home/u/proj/")))) + +;;; Boundary Cases + +(ert-deftest test-coverage-project-root-falls-back-when-projectile-absent () + "Boundary: with no projectile function, falls back to default-directory." + (cl-letf (((symbol-function 'projectile-project-root) nil)) + (let ((default-directory "/fallback/dir/")) + (should (equal (cj/--coverage-project-root) "/fallback/dir/"))))) + +(ert-deftest test-coverage-project-root-falls-back-when-not-in-project () + "Boundary: projectile present but returns nil (not in a project) falls back." + (cl-letf (((symbol-function 'projectile-project-root) (lambda () nil))) + (let ((default-directory "/fallback/dir/")) + (should (equal (cj/--coverage-project-root) "/fallback/dir/"))))) + +(provide 'test-coverage-core--project-root) +;;; test-coverage-core--project-root.el ends here diff --git a/tests/test-custom-buffer-file-keymap-bindings.el b/tests/test-custom-buffer-file-keymap-bindings.el new file mode 100644 index 000000000..ea9ceb263 --- /dev/null +++ b/tests/test-custom-buffer-file-keymap-bindings.el @@ -0,0 +1,30 @@ +;;; test-custom-buffer-file-keymap-bindings.el --- d/D bindings in the buffer-and-file keymap -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/buffer-and-file-map' should put the destructive op on the capital key and +;; the frequently-used op on the easy lowercase key: D = delete-buffer-and-file, +;; d = diff-buffer-with-file. Guards the swap against silently reverting. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) + +;; Stub dependencies before loading the module (mirrors the sibling tests). +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") +(provide 'ps-print) + +(require 'custom-buffer-file) + +(ert-deftest test-custom-buffer-file-keymap-diff-on-lowercase-d () + "Normal: lowercase d runs diff -- the frequently-used, non-destructive op." + (should (eq (keymap-lookup cj/buffer-and-file-map "d") #'cj/diff-buffer-with-file))) + +(ert-deftest test-custom-buffer-file-keymap-delete-on-capital-d () + "Normal: capital D runs delete -- the destructive op on the capital key." + (should (eq (keymap-lookup cj/buffer-and-file-map "D") #'cj/delete-buffer-and-file))) + +(provide 'test-custom-buffer-file-keymap-bindings) +;;; test-custom-buffer-file-keymap-bindings.el ends here diff --git a/tests/test-custom-comments-comment-heavy-box.el b/tests/test-custom-comments-comment-heavy-box.el index 94d4aaa5f..8acb9ff0b 100644 --- a/tests/test-custom-comments-comment-heavy-box.el +++ b/tests/test-custom-comments-comment-heavy-box.el @@ -64,8 +64,8 @@ Returns the buffer string for assertions." (should (string-match-p "^;; \\*" result)) ;; Middle line should contain centered text (should (string-match-p "Section Header" result)) - ;; Should have side borders - (should (string-match-p "^\\*.*\\*$" result)))) + ;; Interior side-border lines carry the comment prefix/suffix (not a bare *) + (should (string-match-p "^;; \\*.*\\* ;;$" result)))) (ert-deftest test-heavy-box-elisp-custom-decoration () "Should use custom decoration character." @@ -83,8 +83,8 @@ Returns the buffer string for assertions." (let ((result (test-heavy-box-at-column 0 ";;" "" "*" "" 70))) ;; Should still generate 5 lines (should (= 5 (length (split-string result "\n" t)))) - ;; Middle line should just have side borders and spaces - (should (string-match-p "^\\*.*\\*$" result)))) + ;; Middle line should just have side borders and spaces, comment-prefixed + (should (string-match-p "^;; \\*.*\\* ;;$" result)))) (ert-deftest test-heavy-box-elisp-at-column-0 () "Should work at column 0." diff --git a/tests/test-custom-datetime-all-methods.el b/tests/test-custom-datetime-all-methods.el index c9cfa41e2..62b421bdc 100644 --- a/tests/test-custom-datetime-all-methods.el +++ b/tests/test-custom-datetime-all-methods.el @@ -108,5 +108,19 @@ (cj/insert-sortable-date)) (should (string-prefix-p "before 2026-02-15" (buffer-string))))) +;;; Macro-generated commands stay interactive + +(ert-deftest test-custom-datetime-all-methods-are-interactive-commands () + "All six inserters generated by `cj/--define-datetime-inserter' are +interactive commands (so they keep working via M-x and the C-; d keymap)." + (dolist (cmd '(cj/insert-readable-date-time + cj/insert-sortable-date-time + cj/insert-sortable-time + cj/insert-readable-time + cj/insert-sortable-date + cj/insert-readable-date)) + (should (fboundp cmd)) + (should (commandp cmd)))) + (provide 'test-custom-datetime-all-methods) ;;; test-custom-datetime-all-methods.el ends here diff --git a/tests/test-custom-line-paragraph-duplicate-line-or-region.el b/tests/test-custom-line-paragraph-duplicate-line-or-region.el index bd82e00fa..84f5bc2df 100644 --- a/tests/test-custom-line-paragraph-duplicate-line-or-region.el +++ b/tests/test-custom-line-paragraph-duplicate-line-or-region.el @@ -447,5 +447,19 @@ (should (string-match-p "line\u000Cwith\u000Dcontrol\nline\u000Cwith\u000Dcontrol" (buffer-string)))) (test-duplicate-line-or-region-teardown))) +;;; Error Cases + +(ert-deftest test-duplicate-line-or-region-comment-without-syntax-errors () + "Error: requesting a comment in a mode with no comment syntax signals +user-error rather than producing malformed output." + (test-duplicate-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (fundamental-mode) ; no comment-start defined + (insert "line one") + (goto-char (point-min)) + (should-error (cj/duplicate-line-or-region t) :type 'user-error)) + (test-duplicate-line-or-region-teardown))) + (provide 'test-custom-line-paragraph-duplicate-line-or-region) ;;; test-custom-line-paragraph-duplicate-line-or-region.el ends here diff --git a/tests/test-custom-ordering--region-helpers.el b/tests/test-custom-ordering--region-helpers.el new file mode 100644 index 000000000..2ec747966 --- /dev/null +++ b/tests/test-custom-ordering--region-helpers.el @@ -0,0 +1,52 @@ +;;; test-custom-ordering--region-helpers.el --- Tests for the shared ordering region helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--ordering-validate-region and cj/--ordering-replace-region were extracted +;; from the seven pure ordering helpers (the copy-pasted start>end guard) and the +;; interactive ordering commands (the copy-pasted delete-region + insert tail). +;; The per-command behavior stays covered by the existing wrapper/transform +;; tests; these cover the extracted helpers directly. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'custom-ordering) + +;;; cj/--ordering-validate-region + +(ert-deftest test-custom-ordering-validate-region-accepts-ordered () + "Normal: start < end returns nil without signalling." + (should (null (cj/--ordering-validate-region 1 10)))) + +(ert-deftest test-custom-ordering-validate-region-accepts-equal () + "Boundary: start = end (empty region) is allowed." + (should (null (cj/--ordering-validate-region 5 5)))) + +(ert-deftest test-custom-ordering-validate-region-rejects-inverted () + "Error: start > end signals with both positions in the message." + (let ((err (should-error (cj/--ordering-validate-region 10 3) :type 'error))) + (should (string-match-p "10" (error-message-string err))) + (should (string-match-p "3" (error-message-string err))))) + +;;; cj/--ordering-replace-region + +(ert-deftest test-custom-ordering-replace-region-swaps-text () + "Normal: the region between START and END is replaced with INSERTION and +point is left at START." + (with-temp-buffer + (insert "AAAABBBB") + (cj/--ordering-replace-region 1 5 "xx") ; replace the first AAAA + (should (equal "xxBBBB" (buffer-string))) + (should (= (point) 3)))) ; START (1) + len("xx") + +(ert-deftest test-custom-ordering-replace-region-empty-insertion () + "Boundary: an empty INSERTION just deletes the region." + (with-temp-buffer + (insert "keepDROP") + (cj/--ordering-replace-region 5 9 "") ; drop "DROP" (positions 5-8) + (should (equal "keep" (buffer-string))))) + +(provide 'test-custom-ordering--region-helpers) +;;; test-custom-ordering--region-helpers.el ends here diff --git a/tests/test-custom-text-enclose--enclose-region-or-word.el b/tests/test-custom-text-enclose--enclose-region-or-word.el new file mode 100644 index 000000000..4075fb050 --- /dev/null +++ b/tests/test-custom-text-enclose--enclose-region-or-word.el @@ -0,0 +1,62 @@ +;;; test-custom-text-enclose--enclose-region-or-word.el --- Tests for the shared enclose dispatch -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--enclose-region-or-word is the dispatch+edit skeleton extracted from +;; cj/surround/wrap/unwrap-word-or-region (region target, else word at point, +;; else a no-target message). The three commands stay covered by +;; test-custom-text-enclose-public-wrappers.el; these cover the helper directly, +;; including the custom and default no-target messages. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'custom-text-enclose) + +(ert-deftest test-cte-enclose-region-target () + "Normal: an active region is the target; TRANSFORM is applied to it." + (with-temp-buffer + (let ((transient-mark-mode t)) + (insert "abc") + (goto-char (point-min)) + (push-mark (point) t t) + (goto-char (point-max)) + (cj/--enclose-region-or-word #'upcase)) + (should (equal (buffer-string) "ABC")) + (should (= (point) 4)))) ; after the inserted "ABC" (start 1 + 3) + +(ert-deftest test-cte-enclose-word-at-point-target () + "Normal: with no region, the word at point is the target." + (with-temp-buffer + (insert "foo bar") + (goto-char (point-min)) ; point on "foo" + (cj/--enclose-region-or-word (lambda (s) (concat "<" s ">"))) + (should (equal (buffer-string) "<foo> bar")))) + +(ert-deftest test-cte-enclose-no-target-default-message () + "Boundary: no region and no word => default message, buffer untouched." + (with-temp-buffer + (insert " ") ; whitespace, no word + (goto-char (point-min)) + (let ((msg nil)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) + (cj/--enclose-region-or-word #'upcase)) + (should (string-match-p "No word at point" msg)) + (should (equal (buffer-string) " "))))) + +(ert-deftest test-cte-enclose-no-target-custom-message () + "Boundary: a supplied NO-TARGET-MESSAGE overrides the default." + (with-temp-buffer + (insert " ") + (goto-char (point-min)) + (let ((msg nil)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) + (cj/--enclose-region-or-word #'upcase "custom no-target text")) + (should (equal msg "custom no-target text"))))) + +(provide 'test-custom-text-enclose--enclose-region-or-word) +;;; test-custom-text-enclose--enclose-region-or-word.el ends here diff --git a/tests/test-dashboard-config-font-lock.el b/tests/test-dashboard-config-font-lock.el new file mode 100644 index 000000000..d55909723 --- /dev/null +++ b/tests/test-dashboard-config-font-lock.el @@ -0,0 +1,35 @@ +;;; test-dashboard-config-font-lock.el --- dashboard-mode excluded from global font-lock -*- lexical-binding: t; -*- + +;;; Commentary: +;; `global-font-lock-mode' fontifies the *dashboard* buffer and strips the +;; manually-applied `face' text properties dashboard puts on the banner title +;; (`dashboard-banner-logo-title') and the section headings +;; (`dashboard-heading'), so they render in the default face instead of the +;; theme colors. dashboard-config excludes dashboard-mode from global +;; font-lock so those text-property faces survive. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) + +;; Stub package-level deps dashboard-config pulls transitively. +(unless (fboundp 'cj/kill-all-other-buffers-and-windows) + (defun cj/kill-all-other-buffers-and-windows () nil)) +(unless (fboundp 'cj/make-buffer-undead) + (defun cj/make-buffer-undead (_name) nil)) + +(require 'dashboard-config) + +(ert-deftest test-dashboard-config-excludes-dashboard-mode-from-global-font-lock () + "Normal: dashboard-mode is excluded from `font-lock-global-modes'. +Global font-lock must not run in the dashboard buffer, or it strips the +manual face text properties dashboard applies to the banner and headings." + (should (consp font-lock-global-modes)) + (should (eq (car font-lock-global-modes) 'not)) + (should (memq 'dashboard-mode (cdr font-lock-global-modes)))) + +(provide 'test-dashboard-config-font-lock) +;;; test-dashboard-config-font-lock.el ends here diff --git a/tests/test-dashboard-config-launchers.el b/tests/test-dashboard-config-launchers.el index 0ac37f878..e7e8d2f33 100644 --- a/tests/test-dashboard-config-launchers.el +++ b/tests/test-dashboard-config-launchers.el @@ -25,20 +25,22 @@ (require 'dashboard-config) -(defconst test-dash--keys '("c" "d" "t" "a" "r" "b" "f" "m" "e" "i" "g" "s" "l")) +;; Telegram moved from "g" to "G" so "g" is free for dashboard refresh. +;; Signal ("S") added as the 14th launcher. +(defconst test-dash--keys '("c" "d" "t" "a" "r" "b" "f" "m" "e" "i" "G" "s" "l" "S")) ;; ----------------------------- launcher table -------------------------------- (ert-deftest test-dashboard-launchers-keys-in-order () - "Normal: 13 launchers with the expected keys in display order." - (should (= 13 (length cj/dashboard--launchers))) + "Normal: 14 launchers with the expected keys in display order." + (should (= 14 (length cj/dashboard--launchers))) (should (equal test-dash--keys (mapcar (lambda (l) (nth 0 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-launchers-labels-in-order () "Normal: labels in display order (Telegram and Slack reordered so Slack sits next to Linear on the last navigator row)." (should (equal '("Code" "Files" "Terminal" "Agenda" "Feeds" "Books" - "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear") + "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear" "Signal") (mapcar (lambda (l) (nth 3 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-row-sizes-cover-all-launchers () @@ -48,19 +50,19 @@ next to Linear on the last navigator row)." ;; --------------------------- navigator rows ---------------------------------- -(ert-deftest test-dashboard-navigator-rows-grouped-4-4-3-2 () - "Normal: navigator derives rows per `cj/dashboard--row-sizes' (4 4 3 2), with -Slack and Linear sharing the last row." +(ert-deftest test-dashboard-navigator-rows-grouped-4-4-3-3 () + "Normal: navigator derives rows per `cj/dashboard--row-sizes' (4 4 3 3), with +Slack, Linear, and Signal sharing the last row." (cl-letf (((symbol-function 'nerd-icons-faicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-devicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-mdicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-octicon) (lambda (n &rest _) (concat "I:" n)))) (let ((rows (cj/dashboard--navigator-rows))) (should (= 4 (length rows))) - (should (equal '(4 4 3 2) (mapcar #'length rows))) + (should (equal '(4 4 3 3) (mapcar #'length rows))) (should (equal '("Code" "Files" "Terminal" "Agenda") (mapcar (lambda (b) (nth 1 b)) (nth 0 rows)))) - (should (equal '("Slack" "Linear") + (should (equal '("Slack" "Linear" "Signal") (mapcar (lambda (b) (nth 1 b)) (nth 3 rows)))) (let ((btn (car (car rows)))) ; (icon label tooltip action nil " " "") (should (string= "I:nf-fa-code" (nth 0 btn))) @@ -94,7 +96,8 @@ Slack and Linear sharing the last row." ((symbol-function 'cj/erc-switch-to-buffer-with-completion) (lambda (&rest _) (push 'irc calls))) ((symbol-function 'cj/slack-start) (lambda (&rest _) (push 'slack calls))) ((symbol-function 'cj/telega) (lambda (&rest _) (push 'tg calls))) - ((symbol-function 'pearl-list-issues) (lambda (&rest _) (push 'linear calls)))) + ((symbol-function 'pearl-list-issues) (lambda (&rest _) (push 'linear calls))) + ((symbol-function 'cj/signel-message) (lambda (&rest _) (push 'signal calls)))) (cj/dashboard--bind-launchers map) (dolist (key test-dash--keys) (call-interactively (keymap-lookup map key))) @@ -103,7 +106,8 @@ Slack and Linear sharing the last row." (should (memq 'linear calls)) (should (memq 'm-toggle calls)) (should (memq 'm-load calls)) - (should (= 14 (length calls)))))) ; 13 keys, Music fires two + (should (memq 'signal calls)) + (should (= 15 (length calls)))))) ; 14 keys, Music fires two (provide 'test-dashboard-config-launchers) ;;; test-dashboard-config-launchers.el ends here diff --git a/tests/test-dirvish-config-dired-line-directory.el b/tests/test-dirvish-config-dired-line-directory.el deleted file mode 100644 index 7f344c7c0..000000000 --- a/tests/test-dirvish-config-dired-line-directory.el +++ /dev/null @@ -1,56 +0,0 @@ -;;; test-dirvish-config-dired-line-directory.el --- Tests for the directory-line predicate -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/--dired-line-is-directory-p' is the testable predicate behind -;; `cj/dired-mark-all-visible-files'. Dired buffers prefix each file -;; line with a one-char mark column followed by the `ls -l' output, so -;; column 2 is the file-type letter (`d' for directory, `-' for regular -;; file). The wrapper iterates the buffer and skips lines this -;; predicate returns t for; the iteration stays dired-coupled and -;; untested, but the line-classification logic is now isolated. - -;;; Code: - -(require 'ert) -(require 'package) - -(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) -(package-initialize) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "elpa/dirvish-2.3.0/extensions" - user-emacs-directory)) -(require 'user-constants) -(require 'keybindings) -(require 'dirvish-config) - -(ert-deftest test-cj--dired-line-is-directory-p-unmarked-directory () - "Normal: an unmarked directory line (` drwx...') matches." - (should (cj/--dired-line-is-directory-p - " drwxr-xr-x 1 me me 4096 May 10 13:00 subdir/"))) - -(ert-deftest test-cj--dired-line-is-directory-p-marked-directory () - "Normal: a star-marked directory line (`* drwx...') matches." - (should (cj/--dired-line-is-directory-p - "* drwxr-xr-x 1 me me 4096 May 10 13:00 subdir/"))) - -(ert-deftest test-cj--dired-line-is-directory-p-regular-file () - "Normal: a regular file line (` -rw...') does not match." - (should-not (cj/--dired-line-is-directory-p - " -rw-r--r-- 1 me me 42 May 10 13:00 notes.txt"))) - -(ert-deftest test-cj--dired-line-is-directory-p-symlink-line () - "Boundary: a symlink line (` lrwx...') does not match -- only `d' is a dir." - (should-not (cj/--dired-line-is-directory-p - " lrwxrwxrwx 1 me me 12 May 10 13:00 link -> target"))) - -(ert-deftest test-cj--dired-line-is-directory-p-empty-line () - "Boundary: an empty string does not match." - (should-not (cj/--dired-line-is-directory-p ""))) - -(ert-deftest test-cj--dired-line-is-directory-p-header-line () - "Boundary: a dired header (` /path/to:') or `total' line does not match." - (should-not (cj/--dired-line-is-directory-p " /home/me/projects:")) - (should-not (cj/--dired-line-is-directory-p " total 24"))) - -(provide 'test-dirvish-config-dired-line-directory) -;;; test-dirvish-config-dired-line-directory.el ends here diff --git a/tests/test-dirvish-config-hard-delete-command.el b/tests/test-dirvish-config-hard-delete-command.el new file mode 100644 index 000000000..eb12d2830 --- /dev/null +++ b/tests/test-dirvish-config-hard-delete-command.el @@ -0,0 +1,47 @@ +;;; test-dirvish-config-hard-delete-command.el --- Tests for cj/--dirvish-hard-delete-command -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--dirvish-hard-delete-command' is the pure string builder behind the +;; forced `sudo rm -rf' hard-delete bound to D in dirvish. It shell-quotes +;; every path and guards the list with `--' so a leading-dash or space-bearing +;; filename can't be misread. The interactive command (prompt + shell-command) +;; is verified live, not here. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'dirvish-config) + +(ert-deftest test-dirvish-config-hard-delete-command-multiple () + "Normal: two paths are quoted and joined behind `sudo rm -rf -- '." + (should (equal (cj/--dirvish-hard-delete-command '("/tmp/a.txt" "/tmp/b.txt")) + "sudo rm -rf -- /tmp/a.txt /tmp/b.txt"))) + +(ert-deftest test-dirvish-config-hard-delete-command-single () + "Boundary: a single path still carries the `--' option terminator." + (should (equal (cj/--dirvish-hard-delete-command '("/tmp/report.pdf")) + "sudo rm -rf -- /tmp/report.pdf"))) + +(ert-deftest test-dirvish-config-hard-delete-command-spaces-and-dash () + "Boundary: a path with spaces is shell-quoted, and `--' protects a +leading-dash filename from being read as an option." + (let ((cmd (cj/--dirvish-hard-delete-command + '("/tmp/my file.txt" "/tmp/-rf")))) + ;; `--' precedes the paths so `-rf' is a target, not an option. + (should (string-prefix-p "sudo rm -rf -- " cmd)) + ;; the space-bearing path is quoted (not a bare " " splitting the args). + (should (string-match-p (regexp-quote (shell-quote-argument "/tmp/my file.txt")) + cmd)) + (should (string-match-p (regexp-quote (shell-quote-argument "/tmp/-rf")) + cmd)))) + +(ert-deftest test-dirvish-config-hard-delete-command-empty () + "Error: an empty list yields just the prefix (no targets) -- the +interactive command never reaches here, guarding `No file at point' first." + (should (equal (cj/--dirvish-hard-delete-command '()) + "sudo rm -rf -- "))) + +(provide 'test-dirvish-config-hard-delete-command) +;;; test-dirvish-config-hard-delete-command.el ends here diff --git a/tests/test-dirvish-config-mark-all-visible.el b/tests/test-dirvish-config-mark-all-visible.el new file mode 100644 index 000000000..5ed01440c --- /dev/null +++ b/tests/test-dirvish-config-mark-all-visible.el @@ -0,0 +1,68 @@ +;;; test-dirvish-config-mark-all-visible.el --- Tests for marking all visible files -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/dired-mark-all-visible-files' marks every regular file in a Dired +;; buffer and leaves directories unmarked. The loop is exercised here against +;; a real Dired buffer over a temp directory (the line predicate has its own +;; unit tests). The regression this pins: `dired-mark' advances point itself, +;; so an extra `forward-line' skipped every other file and only alternate files +;; got marked. + +;;; Code: + +(require 'ert) +(require 'package) +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "elpa/dirvish-2.3.0/extensions" + user-emacs-directory)) +(require 'user-constants) +(require 'keybindings) +(require 'dirvish-config) +(require 'dired) + +(defun test-dirvish--marked-count () + "Return the number of `*'-marked lines in the current Dired buffer." + (let ((n 0)) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at-p "^\\*") (setq n (1+ n))) + (forward-line 1))) + n)) + +(ert-deftest test-dirvish-mark-all-visible-marks-every-file () + "Normal: all regular files get marked, no skips. +Three files plus a subdirectory; the count of marks must equal the file count." + (let ((dir (make-temp-file "dirvish-mark-test-" t))) + (unwind-protect + (progn + (dolist (f '("a.txt" "b.txt" "c.txt")) + (write-region "" nil (expand-file-name f dir))) + (make-directory (expand-file-name "subdir" dir)) + (let ((buf (dired-noselect dir))) + (unwind-protect + (with-current-buffer buf + (cj/dired-mark-all-visible-files) + (should (= 3 (test-dirvish--marked-count)))) + (kill-buffer buf)))) + (delete-directory dir t)))) + +(ert-deftest test-dirvish-mark-all-visible-leaves-directories-unmarked () + "Boundary: a directory line is never marked." + (let ((dir (make-temp-file "dirvish-mark-test-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "only.txt" dir)) + (make-directory (expand-file-name "adir" dir)) + (let ((buf (dired-noselect dir))) + (unwind-protect + (with-current-buffer buf + (cj/dired-mark-all-visible-files) + (should (= 1 (test-dirvish--marked-count)))) + (kill-buffer buf)))) + (delete-directory dir t)))) + +(provide 'test-dirvish-config-mark-all-visible) +;;; test-dirvish-config-mark-all-visible.el ends here diff --git a/tests/test-dirvish-config-playlist.el b/tests/test-dirvish-config-playlist.el index d059a899a..14bb94ac7 100644 --- a/tests/test-dirvish-config-playlist.el +++ b/tests/test-dirvish-config-playlist.el @@ -10,6 +10,7 @@ ;;; Code: (require 'ert) +(require 'cl-lib) (require 'package) (setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) @@ -93,5 +94,59 @@ lowercase extension list." (dolist (bad '("../evil" "../../etc/cron" "/etc/passwd" "sub/dir/name")) (should-not (cj/--playlist-name-safe-p bad)))) +;;; cj/--playlist-resolve-target +;; +;; Drives the real `file-exists-p' against a temp `music-dir' (mocking a C +;; primitive triggers a native-comp trampoline rebuild that fails under +;; --batch); only the ordinary `read-string' / `read-char-choice' prompts are +;; stubbed. + +(ert-deftest test-cj--playlist-resolve-target-returns-path-for-new-name () + "Normal: a safe name with no existing file returns its .m3u path under music-dir." + (let* ((music-dir (make-temp-file "cj-playlist-" t))) + (unwind-protect + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "roadtrip"))) + (should (equal (expand-file-name "roadtrip.m3u" music-dir) + (cj/--playlist-resolve-target)))) + (delete-directory music-dir t)))) + +(ert-deftest test-cj--playlist-resolve-target-reprompts-on-unsafe-name () + "Boundary: an unsafe name (with `/') re-prompts until a safe name is given." + (let* ((music-dir (make-temp-file "cj-playlist-" t)) + (answers '("../escape" "safe")) + (asked 0)) + (unwind-protect + (cl-letf (((symbol-function 'read-string) + (lambda (&rest _) (prog1 (nth asked answers) (cl-incf asked)))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (should (equal (expand-file-name "safe.m3u" music-dir) + (cj/--playlist-resolve-target))) + (should (= 2 asked))) + (delete-directory music-dir t)))) + +(ert-deftest test-cj--playlist-resolve-target-overwrite-returns-existing-path () + "Normal: when the target exists, choosing overwrite returns the same path." + (let* ((music-dir (make-temp-file "cj-playlist-" t)) + (existing (expand-file-name "mix.m3u" music-dir))) + (unwind-protect + (progn + (with-temp-file existing (insert "old\n")) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "mix")) + ((symbol-function 'read-char-choice) (lambda (&rest _) ?o))) + (should (equal existing (cj/--playlist-resolve-target))))) + (delete-directory music-dir t)))) + +(ert-deftest test-cj--playlist-resolve-target-cancel-signals-user-error () + "Error: when the target exists, choosing cancel aborts with a `user-error'." + (let* ((music-dir (make-temp-file "cj-playlist-" t)) + (existing (expand-file-name "mix.m3u" music-dir))) + (unwind-protect + (progn + (with-temp-file existing (insert "old\n")) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "mix")) + ((symbol-function 'read-char-choice) (lambda (&rest _) ?c))) + (should-error (cj/--playlist-resolve-target) :type 'user-error))) + (delete-directory music-dir t)))) + (provide 'test-dirvish-config-playlist) ;;; test-dirvish-config-playlist.el ends here diff --git a/tests/test-dirvish-config-public-wrappers.el b/tests/test-dirvish-config-public-wrappers.el index 0a9998646..cec979e4a 100644 --- a/tests/test-dirvish-config-public-wrappers.el +++ b/tests/test-dirvish-config-public-wrappers.el @@ -101,22 +101,9 @@ confused when several built-ins are overridden in the same test." (when (file-exists-p dst) (delete-file dst))))) ;;; cj/dired-mark-all-visible-files - -(ert-deftest test-dirvish-mark-all-visible-skips-directories () - "Normal: directory lines are skipped, file lines are marked." - (let ((marks 0)) - (with-temp-buffer - ;; Real dired listing has lines like " drwxr... dir/" or " -rw... file". - ;; The helper `cj/--dired-line-is-directory-p' matches "<space>d". - (insert " drwxr-xr-x subdir\n" - " -rw-r--r-- file1.txt\n" - " -rw-r--r-- file2.txt\n") - (goto-char (point-min)) - (cl-letf (((symbol-function 'dired-mark) - (lambda (&rest _) (cl-incf marks)))) - (cj/dired-mark-all-visible-files))) - ;; 2 file lines marked; the directory line + the trailing empty line skipped. - (should (= marks 2)))) +;; Covered by test-dirvish-config-mark-all-visible.el, which exercises the loop +;; against a real Dired buffer (the previous fake-buffer mock coupled to the +;; retired regex helper). ;;; cj/dired-copy-path-as-kill diff --git a/tests/test-dupre-theme.el b/tests/test-dupre-theme.el deleted file mode 100644 index 4d0e786cb..000000000 --- a/tests/test-dupre-theme.el +++ /dev/null @@ -1,261 +0,0 @@ -;;; test-dupre-theme.el --- Tests for dupre-theme -*- lexical-binding: t -*- - -;;; Commentary: - -;; ERT tests for the dupre-theme. - -;;; Code: - -(require 'ert) - -;; Add themes directory to load-path and custom-theme-load-path -(let ((themes-dir (expand-file-name "../themes" (file-name-directory (or load-file-name buffer-file-name))))) - (add-to-list 'load-path themes-dir) - (add-to-list 'custom-theme-load-path themes-dir)) - -(require 'dupre-palette) - -;;; Palette tests - -(ert-deftest dupre-palette-exists () - "Palette constant should be defined." - (should (boundp 'dupre-palette)) - (should (listp dupre-palette))) - -(ert-deftest dupre-palette-has-base-colors () - "Palette should contain essential base colors." - (should (assq 'bg dupre-palette)) - (should (assq 'fg dupre-palette)) - (should (assq 'bg+1 dupre-palette)) - (should (assq 'bg+2 dupre-palette))) - -(ert-deftest dupre-palette-has-accent-colors () - "Palette should contain accent colors." - (should (assq 'yellow dupre-palette)) - (should (assq 'blue dupre-palette)) - (should (assq 'green dupre-palette)) - (should (assq 'red dupre-palette))) - -(ert-deftest dupre-palette-colors-are-hex () - "All palette colors should be valid hex strings." - (dolist (entry dupre-palette) - (let ((color (cadr entry))) - (should (stringp color)) - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" color))))) - -(ert-deftest dupre-get-color-base () - "dupre-get-color should retrieve base colors." - (should (string= (dupre-get-color 'bg) "#151311")) - (should (string= (dupre-get-color 'fg) "#f0fef0")) - (should (string= (dupre-get-color 'yellow) "#d7af5f"))) - -(ert-deftest dupre-get-color-semantic () - "dupre-get-color should resolve semantic mappings." - (should (string= (dupre-get-color 'accent) (dupre-get-color 'yellow))) - (should (string= (dupre-get-color 'err) (dupre-get-color 'intense-red))) - (should (string= (dupre-get-color 'success) (dupre-get-color 'green)))) - -(ert-deftest dupre-get-color-unknown-errors () - "dupre-get-color should error on unknown colors." - (should-error (dupre-get-color 'nonexistent-color))) - -(ert-deftest dupre-with-colors-binds-values () - "dupre-with-colors should bind palette colors as variables." - (dupre-with-colors - (should (string= bg "#151311")) - (should (string= fg "#f0fef0")) - (should (string= yellow "#d7af5f")) - (should (string= blue "#67809c")))) - -(ert-deftest dupre-with-colors-binds-semantic () - "dupre-with-colors should bind semantic colors resolved to values." - (dupre-with-colors - (should (string= accent "#d7af5f")) - (should (string= err "#ff2a00")) - (should (string= success "#a4ac64")))) - -;;; Theme loading tests - -(ert-deftest dupre-theme-loads () - "Theme should load without errors." - (load-theme 'dupre t) - (should (memq 'dupre custom-enabled-themes))) - -(ert-deftest dupre-theme-default-face () - "dupre-theme should set the default face correctly." - (load-theme 'dupre t) - (let ((bg (face-attribute 'default :background)) - (fg (face-attribute 'default :foreground))) - (should (string= bg "#151311")) - (should (string= fg "#f0fef0")))) - -(ert-deftest dupre-theme-comment-face-italic () - "Comments should be rendered in italic slant." - (load-theme 'dupre t) - (should (eq (face-attribute 'font-lock-comment-face :slant) 'italic))) - -(ert-deftest dupre-theme-keyword-face () - "Keywords should use blue color." - (load-theme 'dupre t) - (should (string= (face-attribute 'font-lock-keyword-face :foreground) "#67809c"))) - -(ert-deftest dupre-theme-string-face () - "Strings should use green color." - (load-theme 'dupre t) - (should (string= (face-attribute 'font-lock-string-face :foreground) "#a4ac64"))) - -(ert-deftest dupre-theme-function-face () - "Functions should use terracotta color." - (load-theme 'dupre t) - (should (string= (face-attribute 'font-lock-function-name-face :foreground) "#a7502d"))) - -;;; Org-mode face tests (require org to be loaded) -;; Note: org-level-N faces use :inherit dupre-heading-N -;; We verify inheritance is set up correctly by checking the inherit attribute - -(ert-deftest dupre-theme-org-level-1 () - "Org level 1 should inherit from dupre-heading-1." - (require 'org) - (load-theme 'dupre t) - ;; Verify the inheritance relationship is set - (should (eq (face-attribute 'org-level-1 :inherit) 'dupre-heading-1))) - -(ert-deftest dupre-theme-org-level-2 () - "Org level 2 should inherit from dupre-heading-2." - (require 'org) - (load-theme 'dupre t) - ;; Verify the inheritance relationship is set - (should (eq (face-attribute 'org-level-2 :inherit) 'dupre-heading-2))) - -(ert-deftest dupre-theme-org-todo () - "Org TODO should use intense-red." - (require 'org) - (load-theme 'dupre t) - (should (string= (face-attribute 'org-todo :foreground) "#ff2a00"))) - -(ert-deftest dupre-theme-org-done () - "Org DONE should use green." - (require 'org) - (load-theme 'dupre t) - (should (string= (face-attribute 'org-done :foreground) "#a4ac64"))) - -;;; Diff face tests (require diff-mode to be loaded) - -(ert-deftest dupre-theme-diff-added () - "Diff added should use green foreground." - (require 'diff-mode) - (load-theme 'dupre t) - (should (string= (face-attribute 'diff-added :foreground) "#a4ac64"))) - -(ert-deftest dupre-theme-diff-removed () - "Diff removed should use red foreground." - (require 'diff-mode) - (load-theme 'dupre t) - (should (string= (face-attribute 'diff-removed :foreground) "#d47c59"))) - -;;; UI face tests - -(ert-deftest dupre-theme-mode-line () - "Mode line should have correct background." - (load-theme 'dupre t) - (should (string= (face-attribute 'mode-line :background) "#474544"))) - -(ert-deftest dupre-theme-region () - "Region should use bg+2 as background." - (load-theme 'dupre t) - (should (string= (face-attribute 'region :background) "#474544"))) - -;;; Vertico face tests (skip if vertico not available) - -(ert-deftest dupre-theme-vertico-current () - "Vertico current should use bg+2 background." - (skip-unless (require 'vertico nil t)) - (load-theme 'dupre t) - (should (string= (face-attribute 'vertico-current :background) "#474544"))) - -;;; Rainbow-delimiters tests (skip if package not available) - -(ert-deftest dupre-theme-rainbow-depth-1 () - "Rainbow depth 1 should use blue." - (skip-unless (require 'rainbow-delimiters nil t)) - (load-theme 'dupre t) - (should (string= (face-attribute 'rainbow-delimiters-depth-1-face :foreground) "#67809c"))) - -(ert-deftest dupre-theme-rainbow-depth-2 () - "Rainbow depth 2 should use gray+2." - (skip-unless (require 'rainbow-delimiters nil t)) - (load-theme 'dupre t) - (should (string= (face-attribute 'rainbow-delimiters-depth-2-face :foreground) "#d0cbc0"))) - -;;; Error/warning face tests - -(ert-deftest dupre-theme-error-face () - "Error face should use intense-red." - (load-theme 'dupre t) - (should (string= (face-attribute 'error :foreground) "#ff2a00"))) - -(ert-deftest dupre-theme-warning-face () - "Warning face should use yellow+1." - (load-theme 'dupre t) - (should (string= (face-attribute 'warning :foreground) "#ffd75f"))) - -(ert-deftest dupre-theme-success-face () - "Success face should use green." - (load-theme 'dupre t) - (should (string= (face-attribute 'success :foreground) "#a4ac64"))) - -;;; Face registration - -(ert-deftest dupre-semantic-faces-are-registered () - "Dupre's own faces must be real faces, not just theme specs. -An unregistered face renders only through `:inherit'; applied directly as -a text property (e.g. via `org-todo-keyword-faces') it silently fails. -The defface registration in dupre-faces.el is what makes direct use work." - (load-theme 'dupre t) - (dolist (face '(dupre-accent dupre-heading-1 - dupre-org-todo dupre-org-todo-dim - dupre-org-failed dupre-org-priority-a - dupre-org-priority-a-dim)) - (should (facep face))) - ;; and the theme colours them from the palette - (should (string= (face-attribute 'dupre-org-todo :foreground nil 'default) - "#a4ac64")) - (should (string= (face-attribute 'dupre-org-todo-dim :foreground nil 'default) - "#869038"))) - -;;; Diff face legibility (WCAG contrast) - -(defun dupre-test--channel-luminance (c) - "Linearize an 8-bit channel value C (0-255) per the WCAG formula." - (let ((x (/ c 255.0))) - (if (<= x 0.03928) (/ x 12.92) (expt (/ (+ x 0.055) 1.055) 2.4)))) - -(defun dupre-test--relative-luminance (hex) - "WCAG relative luminance of HEX color \"#rrggbb\"." - (+ (* 0.2126 (dupre-test--channel-luminance (string-to-number (substring hex 1 3) 16))) - (* 0.7152 (dupre-test--channel-luminance (string-to-number (substring hex 3 5) 16))) - (* 0.0722 (dupre-test--channel-luminance (string-to-number (substring hex 5 7) 16))))) - -(defun dupre-test--contrast (fg bg) - "WCAG contrast ratio between hex colors FG and BG." - (let ((l1 (dupre-test--relative-luminance fg)) - (l2 (dupre-test--relative-luminance bg))) - (/ (+ (max l1 l2) 0.05) (+ (min l1 l2) 0.05)))) - -(ert-deftest dupre-diff-changed-faces-meet-wcag-aa () - "Error/Regression: diff-changed and diff-refine-changed must stay legible as -standalone backgrounds (WCAG AA, >= 4.5:1 for normal text). Guards the bug -where diff-refine-changed rendered the default fg (#f0fef0) on the bright-gold -yellow-1 (#ffd700) at 1.35:1 -- unreadable wherever the face is used as a plain -background, not just inside diff-mode's own foreground overlay." - (require 'diff-mode) - (load-theme 'dupre t) - (dolist (face '(diff-changed diff-refine-changed)) - (let ((fg (face-attribute face :foreground nil t)) - (bg (face-attribute face :background nil t))) - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" fg)) - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" bg)) - (should (>= (dupre-test--contrast fg bg) 4.5))))) - -(provide 'test-dupre-theme) -;;; test-dupre-theme.el ends here diff --git a/tests/test-dwim-shell-config-command-fixes.el b/tests/test-dwim-shell-config-command-fixes.el new file mode 100644 index 000000000..2cc3ae72b --- /dev/null +++ b/tests/test-dwim-shell-config-command-fixes.el @@ -0,0 +1,88 @@ +;;; test-dwim-shell-config-command-fixes.el --- zip/backup command builders -*- lexical-binding: t; -*- + +;;; Commentary: +;; Two audit fixes, extracted into top-level command-string builders so they're +;; testable without loading the dwim-shell-command package (the command defuns +;; that call them live inside its use-package :config, which the batch test +;; harness doesn't instantiate): +;; - cj/dwim-shell--zip-single-file-command names the archive <fne>.zip +;; - cj/dwim-shell--dated-backup-command carries a real timestamp, not "$(date)" +;; The third fix (dired menu key M-S-d -> M-D) is a keybinding inside the same +;; :config block; it's verified in the live daemon, not here. + +;;; Code: + +(require 'ert) +(require 'dwim-shell-config) + +(ert-deftest test-dwim-zip-single-file-command-names-archive-dot-zip () + "Normal: the single-file zip template names the archive <fne>.zip, with no +leftover <<e>> that would rebuild the input filename." + (let ((cmd (cj/dwim-shell--zip-single-file-command))) + (should (string-match-p "'<<fne>>\\.zip'" cmd)) + (should-not (string-match-p "<<e>>" cmd)))) + +(ert-deftest test-dwim-dated-backup-command-carries-real-timestamp () + "Normal: the dated-backup template interpolates a real YYYYMMDD_HHMMSS stamp, +so the substitution can't sit dead inside single quotes." + (let ((cmd (cj/dwim-shell--dated-backup-command))) + (should (string-match-p "\\.[0-9]\\{8\\}_[0-9]\\{6\\}\\.bak'" cmd)) + (should-not (string-match-p "\\$(date" cmd)))) + +;;; ----------------------- tar-gzip command builder -------------------------- + +(ert-deftest test-dwim-tar-gzip-command-single-names-after-file () + "Normal: a single marked file names the archive <fne>.tar.gz over <<f>>." + (let ((cmd (cj/dwim-shell--tar-gzip-command t))) + (should (string-match-p "'<<fne>>\\.tar\\.gz'" cmd)) + (should (string-match-p "'<<f>>'" cmd)))) + +(ert-deftest test-dwim-tar-gzip-command-multi-uses-shared-archive () + "Boundary: multiple files tar into a shared archive.tar.gz over <<*>>." + (let ((cmd (cj/dwim-shell--tar-gzip-command nil))) + (should (string-match-p "archive\\.tar\\.gz" cmd)) + (should (string-match-p "'<<\\*>>'" cmd)))) + +;;; --------------------- text-to-speech command builder ---------------------- + +(ert-deftest test-dwim-text-to-speech-command-darwin-uses-say-voice () + "Normal: on darwin the command uses `say' with the chosen voice." + (let ((cmd (cj/dwim-shell--text-to-speech-command 'darwin "Samantha"))) + (should (string-match-p "\\`say -v Samantha " cmd)) + (should (string-match-p "'<<fne>>\\.aiff'" cmd)))) + +(ert-deftest test-dwim-text-to-speech-command-linux-uses-espeak () + "Boundary: a non-darwin system uses `espeak' and ignores the voice." + (let ((cmd (cj/dwim-shell--text-to-speech-command 'gnu/linux "ignored"))) + (should (string-match-p "\\`espeak " cmd)) + (should (string-match-p "'<<fne>>\\.wav'" cmd)) + (should-not (string-match-p "ignored" cmd)))) + +;;; ----------------------- video-trim command builder ------------------------ + +(ert-deftest test-dwim-video-trim-command-beginning-uses-ss () + "Normal: trimming the beginning emits a leading -ss with the start seconds." + (let ((cmd (cj/dwim-shell--video-trim-command "Beginning" 7 0))) + (should (string-match-p "-ss 7 " cmd)) + (should-not (string-match-p "-sseof" cmd)))) + +(ert-deftest test-dwim-video-trim-command-end-uses-sseof () + "Normal: trimming the end emits -sseof with the end seconds, no -ss." + (let ((cmd (cj/dwim-shell--video-trim-command "End" 0 9))) + (should (string-match-p "-sseof -9 " cmd)) + (should-not (string-match-p "-ss [0-9]" cmd)))) + +(ert-deftest test-dwim-video-trim-command-both-uses-ss-and-sseof () + "Normal: trimming both ends emits both -ss start and -sseof end." + (let ((cmd (cj/dwim-shell--video-trim-command "Both" 3 4))) + (should (string-match-p "-ss 3 " cmd)) + (should (string-match-p "-sseof -4 " cmd)))) + +(ert-deftest test-dwim-video-trim-command-negative-seconds-errors () + "Error: a negative second count for the used side signals a user-error." + (should-error (cj/dwim-shell--video-trim-command "Beginning" -1 0) :type 'user-error) + (should-error (cj/dwim-shell--video-trim-command "End" 0 -1) :type 'user-error) + (should-error (cj/dwim-shell--video-trim-command "Both" 0 -2) :type 'user-error)) + +(provide 'test-dwim-shell-config-command-fixes) +;;; test-dwim-shell-config-command-fixes.el ends here diff --git a/tests/test-elfeed-config--decode-html-entities.el b/tests/test-elfeed-config--decode-html-entities.el new file mode 100644 index 000000000..a3fba3c49 --- /dev/null +++ b/tests/test-elfeed-config--decode-html-entities.el @@ -0,0 +1,31 @@ +;;; test-elfeed-config--decode-html-entities.el --- Tests for cj/--decode-html-entities -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--decode-html-entities replaces the six inline replace-regexp-in-string +;; calls that cj/youtube-to-elfeed-feed-format used to hand-decode an og:title. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'elfeed-config) + +(ert-deftest test-elfeed-decode-html-entities-all () + "Normal: every supported entity is decoded." + (should (equal (cj/--decode-html-entities + "a & b <c> "d" 'e'") + "a & b <c> \"d\" 'e'"))) + +(ert-deftest test-elfeed-decode-html-entities-no-entities () + "Boundary: text without entities is unchanged." + (should (equal (cj/--decode-html-entities "plain title") "plain title")) + (should (equal (cj/--decode-html-entities "") ""))) + +(ert-deftest test-elfeed-decode-html-entities-amp-first () + "Boundary: & is decoded before the others (no double-decoding chains)." + (should (equal (cj/--decode-html-entities "Tom & Jerry <3") + "Tom & Jerry <3"))) + +(provide 'test-elfeed-config--decode-html-entities) +;;; test-elfeed-config--decode-html-entities.el ends here diff --git a/tests/test-elfeed-config-youtube-feed-format.el b/tests/test-elfeed-config-youtube-feed-format.el index bda90aa7d..f6c82881e 100644 --- a/tests/test-elfeed-config-youtube-feed-format.el +++ b/tests/test-elfeed-config-youtube-feed-format.el @@ -65,5 +65,49 @@ (should-error (cj/youtube-to-elfeed-feed-format "https://youtube.com/@t" 'channel)) (should-not (buffer-live-p url-buf))))) +;;; Playlist branch + +(ert-deftest test-elfeed-youtube-playlist-parses-id-and-title () + "Normal: a playlist URL yields the playlist feed line and the og:title." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) + (test-elfeed--url-buffer + "<meta property=\"og:title\" content=\"My Playlist\">")))) + (let ((result (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/playlist?list=PLabc123" 'playlist))) + (should (string-match-p "playlist_id=PLabc123" result)) + (should (string-match-p "My Playlist" result))))) + +(ert-deftest test-elfeed-youtube-playlist-id-stops-at-ampersand () + "Boundary: extra query params after list= are not captured into the id." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) + (test-elfeed--url-buffer + "<meta property=\"og:title\" content=\"X\">")))) + (let ((result (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/playlist?list=PLxyz&index=2" 'playlist))) + (should (string-match-p "playlist_id=PLxyz" result)) + (should-not (string-match-p "index=2" result))))) + +(ert-deftest test-elfeed-youtube-playlist-no-list-param-errors () + "Error: a playlist URL with no list= parameter signals an extraction error." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) (test-elfeed--url-buffer "")))) + (should-error (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/watch?v=abc" 'playlist)))) + +(ert-deftest test-elfeed-youtube-playlist-decodes-html-entities-in-title () + "Normal: HTML entities in the og:title are decoded in the feed comment." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) + (test-elfeed--url-buffer + (concat "<meta property=\"og:title\" content=\"" + "Rock & Roll 'n' <Test> "X"" + "\">"))))) + (let ((result (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/playlist?list=PLe" 'playlist))) + (should (string-match-p (regexp-quote "Rock & Roll 'n' <Test> \"X\"") + result))))) + (provide 'test-elfeed-config-youtube-feed-format) ;;; test-elfeed-config-youtube-feed-format.el ends here diff --git a/tests/test-erc-config--generate-buffer-name.el b/tests/test-erc-config--generate-buffer-name.el new file mode 100644 index 000000000..cbc716c82 --- /dev/null +++ b/tests/test-erc-config--generate-buffer-name.el @@ -0,0 +1,31 @@ +;;; test-erc-config--generate-buffer-name.el --- Tests for cj/erc-generate-buffer-name -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/erc-generate-buffer-name formats an ERC buffer name as SERVER-CHANNEL. +;; It was defined inside the erc use-package :config (so unreachable under +;; `make test'); lifting it to top level makes it unit-testable. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'erc-config) + +(ert-deftest test-erc-generate-buffer-name-server-and-channel () + "Normal: a target yields SERVER-CHANNEL." + (should (equal (cj/erc-generate-buffer-name '(:server "libera" :target "#emacs")) + "libera-#emacs"))) + +(ert-deftest test-erc-generate-buffer-name-server-only () + "Boundary: no target yields just the server name." + (should (equal (cj/erc-generate-buffer-name '(:server "libera")) + "libera"))) + +(ert-deftest test-erc-generate-buffer-name-missing-pieces () + "Boundary: missing server/target degrade to empty strings, not nil." + (should (equal (cj/erc-generate-buffer-name '(:target "#emacs")) "-#emacs")) + (should (equal (cj/erc-generate-buffer-name '()) ""))) + +(provide 'test-erc-config--generate-buffer-name) +;;; test-erc-config--generate-buffer-name.el ends here diff --git a/tests/test-erc-config-connected-servers.el b/tests/test-erc-config-connected-servers.el new file mode 100644 index 000000000..7d4540d68 --- /dev/null +++ b/tests/test-erc-config-connected-servers.el @@ -0,0 +1,48 @@ +;;; test-erc-config-connected-servers.el --- cj/erc-connected-servers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/erc-connected-servers must return only ERC *server* buffers with a live +;; process. The original test compared a buffer's own erc-server-process to the +;; same buffer-local value inside `with-current-buffer', which is always true, so +;; it returned every ERC buffer (channels, queries, dead connections). These +;; tests stub `erc-buffer-list' and the two ERC predicates so the classification +;; is exercised without a real IRC connection. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'erc-config) + +(ert-deftest test-erc-connected-servers-keeps-only-live-server-buffers () + "Normal: only buffers that are ERC server buffers with a live process are +returned; a channel buffer and a dead-connection server buffer are excluded." + (let ((b-server (generate-new-buffer " *erc-server*")) + (b-channel (generate-new-buffer " *erc-#chan*")) + (b-dead (generate-new-buffer " *erc-dead*"))) + (unwind-protect + (cl-letf (((symbol-function 'erc-buffer-list) + (lambda (&rest _) (list b-server b-channel b-dead))) + ((symbol-function 'erc-server-buffer-p) + (lambda (&rest _) (memq (current-buffer) (list b-server b-dead)))) + ((symbol-function 'erc-server-process-alive) + (lambda (&rest _) (eq (current-buffer) b-server)))) + (should (equal (cj/erc-connected-servers) + (list (buffer-name b-server))))) + (mapc #'kill-buffer (list b-server b-channel b-dead))))) + +(ert-deftest test-erc-connected-servers-empty-when-none-alive () + "Boundary: no live server buffers yields an empty list." + (let ((b-channel (generate-new-buffer " *erc-#chan*"))) + (unwind-protect + (cl-letf (((symbol-function 'erc-buffer-list) + (lambda (&rest _) (list b-channel))) + ((symbol-function 'erc-server-buffer-p) (lambda (&rest _) nil)) + ((symbol-function 'erc-server-process-alive) (lambda (&rest _) nil))) + (should (null (cj/erc-connected-servers)))) + (kill-buffer b-channel)))) + +(provide 'test-erc-config-connected-servers) +;;; test-erc-config-connected-servers.el ends here diff --git a/tests/test-face-diagnostic.el b/tests/test-face-diagnostic.el new file mode 100644 index 000000000..241425fc5 --- /dev/null +++ b/tests/test-face-diagnostic.el @@ -0,0 +1,332 @@ +;;; test-face-diagnostic.el --- Tests for the Phase 1 face-diagnosis core -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the pure read model of the face/font diagnostic (Phase 1): +;; buffer classification, character context, and the face stack separated by +;; source. All against temp-buffer fixtures with planted text properties, +;; overlays, and face remaps -- no display, no prompts. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'face-diagnostic) + +;;; cj/--face-diag-classify-buffer + +(ert-deftest test-face-diag-classify-theme-faced () + "Normal: an ordinary buffer classifies as theme-faced." + (with-temp-buffer + (fundamental-mode) + (should (eq (cj/--face-diag-classify-buffer) 'theme-faced)))) + +(ert-deftest test-face-diag-classify-terminal () + "Boundary: a terminal-family mode classifies as terminal-ansi." + (with-temp-buffer + (setq major-mode 'term-mode) + (should (eq (cj/--face-diag-classify-buffer) 'terminal-ansi)))) + +(ert-deftest test-face-diag-classify-document () + "Boundary: an shr-rendering mode classifies as document-shr." + (with-temp-buffer + (setq major-mode 'eww-mode) + (should (eq (cj/--face-diag-classify-buffer) 'document-shr)))) + +(ert-deftest test-face-diag-classify-image () + "Boundary: an image/document-view mode classifies as image-no-text." + (with-temp-buffer + (setq major-mode 'image-mode) + (should (eq (cj/--face-diag-classify-buffer) 'image-no-text)))) + +;;; cj/--face-diag-char-context + +(ert-deftest test-face-diag-char-context-normal () + "Normal: an ASCII letter reports char, codepoint, name, and script." + (with-temp-buffer + (insert "A") + (let ((ctx (cj/--face-diag-char-context (point-min)))) + (should (= (plist-get ctx :char) ?A)) + (should (= (plist-get ctx :codepoint) 65)) + (should (equal (plist-get ctx :name) "LATIN CAPITAL LETTER A")) + (should (eq (plist-get ctx :script) 'latin))))) + +(ert-deftest test-face-diag-char-context-eob-nil () + "Boundary/Error: end of an empty buffer has no character, so nil." + (with-temp-buffer + (should-not (cj/--face-diag-char-context (point-max))))) + +;;; cj/--face-diag-normalize-faces + +(ert-deftest test-face-diag-normalize-faces () + "Normal/Boundary: symbol, list, anonymous spec, and nil normalize correctly." + (should (equal (cj/--face-diag-normalize-faces 'bold) '(bold))) + (should (equal (cj/--face-diag-normalize-faces '(bold italic)) '(bold italic))) + (should (equal (cj/--face-diag-normalize-faces '(:foreground "red")) + '((:foreground "red")))) + (should-not (cj/--face-diag-normalize-faces nil))) + +;;; cj/--face-diag-text-property-faces + +(ert-deftest test-face-diag-text-property-faces-symbol () + "Normal: a `face' property symbol appears in the list." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (should (equal (cj/--face-diag-text-property-faces (point-min)) '(bold))))) + +(ert-deftest test-face-diag-text-property-faces-includes-font-lock () + "Normal: `face' and `font-lock-face' are both collected, face first." + (with-temp-buffer + (insert (propertize "x" 'face 'bold 'font-lock-face 'italic)) + (should (equal (cj/--face-diag-text-property-faces (point-min)) '(bold italic))))) + +(ert-deftest test-face-diag-text-property-faces-none () + "Boundary: unpropertized text yields no faces." + (with-temp-buffer + (insert "x") + (should-not (cj/--face-diag-text-property-faces (point-min))))) + +;;; cj/--face-diag-overlay-faces + +(ert-deftest test-face-diag-overlay-faces-sorted-by-priority () + "Normal: overlay faces are returned highest priority first." + (with-temp-buffer + (insert "xyz") + (let ((lo (make-overlay 1 3)) + (hi (make-overlay 1 3))) + (overlay-put lo 'face 'region) + (overlay-put lo 'priority 1) + (overlay-put hi 'face 'highlight) + (overlay-put hi 'priority 10) + (let ((entries (cj/--face-diag-overlay-faces 1))) + (should (= (length entries) 2)) + (should (eq (plist-get (car entries) :face) 'highlight)) + (should (eq (plist-get (cadr entries) :face) 'region)))))) + +(ert-deftest test-face-diag-overlay-faces-skips-faceless () + "Boundary: an overlay without a `face' property is excluded." + (with-temp-buffer + (insert "xyz") + (let ((ov (make-overlay 1 3))) + (overlay-put ov 'help-echo "no face here") + (should-not (cj/--face-diag-overlay-faces 1))))) + +;;; cj/--face-diag-active-remaps + +(ert-deftest test-face-diag-active-remaps-matches-stack () + "Normal: a remap of a stack face is returned; an unrelated remap is not." + (with-temp-buffer + (setq face-remapping-alist '((default :background "#111111") + (link :foreground "#222222"))) + (let ((remaps (cj/--face-diag-active-remaps '(default)))) + (should (assq 'default remaps)) + (should-not (assq 'link remaps))))) + +(ert-deftest test-face-diag-active-remaps-empty () + "Boundary: no remapping alist yields no entries." + (with-temp-buffer + (setq face-remapping-alist nil) + (should-not (cj/--face-diag-active-remaps '(default))))) + +;;; cj/--face-diag-stack + +(ert-deftest test-face-diag-stack-assembles-sources () + "Normal: the stack carries text-property, overlay, remap, and default sources." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (setq face-remapping-alist '((default :background "#111111"))) + (let ((ov (make-overlay 1 2))) + (overlay-put ov 'face 'region) + (let ((stack (cj/--face-diag-stack 1))) + (should (equal (plist-get stack :text-property) '(bold))) + (should (eq (plist-get (car (plist-get stack :overlays)) :face) 'region)) + (should (assq 'default (plist-get stack :remaps))) + (should (eq (plist-get stack :default) 'default)))))) + +;;; cj/--face-diagnosis-at + +(ert-deftest test-face-diagnosis-at-shape () + "Normal: the assembled core returns classification, char, and stack." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "A" 'face 'bold)) + (let ((diag (cj/--face-diagnosis-at (point-min)))) + (should (eq (plist-get diag :classification) 'theme-faced)) + (should (= (plist-get (plist-get diag :char) :char) ?A)) + (should (equal (plist-get (plist-get diag :stack) :text-property) '(bold)))))) + +(ert-deftest test-face-diagnosis-at-eob-char-nil () + "Boundary: at end of an empty buffer the char group is nil, stack still present." + (with-temp-buffer + (fundamental-mode) + (let ((diag (cj/--face-diagnosis-at (point-max)))) + (should-not (plist-get diag :char)) + (should (eq (plist-get (plist-get diag :stack) :default) 'default))))) + +;;; cj/--face-diag-merged-attributes + +(ert-deftest test-face-diag-merged-explicit-text-prop () + "Normal: an explicit text-property attribute is the winning merged value." + (with-temp-buffer + (insert (propertize "x" 'face '(:foreground "#abcdef" :weight bold))) + (let ((attrs (cj/--face-diag-merged-attributes (point-min)))) + (should (equal (plist-get attrs :foreground) "#abcdef")) + (should (eq (plist-get attrs :weight) 'bold))))) + +(ert-deftest test-face-diag-merged-overlay-wins-over-text-prop () + "Normal: a higher-priority overlay attribute beats the text-property face." + (with-temp-buffer + (insert (propertize "x" 'face '(:foreground "blue"))) + (let ((ov (make-overlay 1 2))) + (overlay-put ov 'face '(:foreground "red")) + (overlay-put ov 'priority 10) + (should (equal (plist-get (cj/--face-diag-merged-attributes 1) :foreground) + "red"))))) + +(ert-deftest test-face-diag-merged-applies-default-remap () + "Normal: a remap of the default face shows up in the merged attributes." + (with-temp-buffer + (insert "x") + (setq face-remapping-alist '((default :foreground "#123456"))) + (should (equal (plist-get (cj/--face-diag-merged-attributes 1) :foreground) + "#123456")))) + +(ert-deftest test-face-diag-merged-bold-face-symbol () + "Boundary: a face symbol in the stack contributes its set attributes." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (should (eq (plist-get (cj/--face-diag-merged-attributes 1) :weight) 'bold)))) + +;;; cj/--face-diag-real-font + +(ert-deftest test-face-diag-real-font-unavailable-in-batch () + "Boundary: font-at is nil under batch, so the real font reads \"unavailable\"." + (with-temp-buffer + (insert "x") + (let ((font (cj/--face-diag-real-font 1))) + (should (equal (plist-get font :font) "unavailable")) + (should-not (plist-get font :family))))) + +;;; cj/--face-diagnosis-at (groups 0-4) + +(ert-deftest test-face-diagnosis-at-includes-attributes-and-font () + "Normal: the assembled core carries the merged attributes and font groups." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "x" 'face '(:foreground "#abcdef"))) + (let ((diag (cj/--face-diagnosis-at (point-min)))) + (should (equal (plist-get (plist-get diag :attributes) :foreground) "#abcdef")) + (should (equal (plist-get (plist-get diag :font) :font) "unavailable"))))) + +;;; provenance accessors + +(ert-deftest test-face-diag-face-themes () + "Normal: theme names come from the face's theme-face property, newest first." + (make-face 'fd-test-themed) + (put 'fd-test-themed 'theme-face '((user spec1) (dupre spec2))) + (should (equal (cj/--face-diag-face-themes 'fd-test-themed) '(user dupre)))) + +(ert-deftest test-face-diag-config-source () + "Normal/Boundary: saved-face -> saved, customized-face -> customized, else nil." + (make-face 'fd-test-saved) + (put 'fd-test-saved 'saved-face '(spec)) + (make-face 'fd-test-cust) + (put 'fd-test-cust 'customized-face '(spec)) + (make-face 'fd-test-plain) + (should (eq (cj/--face-diag-config-source 'fd-test-saved) 'saved)) + (should (eq (cj/--face-diag-config-source 'fd-test-cust) 'customized)) + (should-not (cj/--face-diag-config-source 'fd-test-plain))) + +(ert-deftest test-face-diag-inherit-chain () + "Normal: a single-symbol :inherit produces a nearest-first chain." + (make-face 'fd-test-parent) + (make-face 'fd-test-child) + (set-face-attribute 'fd-test-child nil :inherit 'fd-test-parent) + (should (equal (cj/--face-diag-inherit-chain 'fd-test-child) '(fd-test-parent)))) + +(ert-deftest test-face-diag-inherit-chain-none () + "Boundary: a face with no :inherit has an empty chain." + (make-face 'fd-test-noinherit) + (should-not (cj/--face-diag-inherit-chain 'fd-test-noinherit))) + +(ert-deftest test-face-diag-unspecified-attrs () + "Normal: a bare face leaves attributes unspecified, so they fall to default." + (make-face 'fd-test-bare) + (should (memq :foreground (cj/--face-diag-unspecified-attrs 'fd-test-bare)))) + +(ert-deftest test-face-diag-provenance-covers-stack-and-default () + "Normal: provenance covers the stack's named faces and always the default." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (let ((faces (mapcar (lambda (p) (plist-get p :face)) + (cj/--face-diag-provenance (point-min))))) + (should (memq 'bold faces)) + (should (memq 'default faces))))) + +(ert-deftest test-face-diagnosis-at-includes-provenance () + "Normal: the assembled core carries the provenance group for stack faces." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "x" 'face 'bold)) + (let ((prov (plist-get (cj/--face-diagnosis-at (point-min)) :provenance))) + (should (cl-some (lambda (p) (eq (plist-get p :face) 'bold)) prov))))) + +;;; cj/--face-diag-render + +(ert-deftest test-face-diag-render-has-all-groups () + "Normal: the rendered report names every group and the stack's face." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "A" 'face 'bold)) + (let ((report (cj/--face-diag-render (cj/--face-diagnosis-at (point-min))))) + (should (string-match-p "Character:" report)) + (should (string-match-p "Face stack" report)) + (should (string-match-p "bold" report)) + (should (string-match-p "Effective attributes" report)) + (should (string-match-p "Real font" report)) + (should (string-match-p "Provenance" report))))) + +(ert-deftest test-face-diag-render-banner-out-of-scope () + "Boundary: a terminal classification renders a banner naming the ANSI source." + (should (string-match-p "terminal" (cj/--face-diag-render-banner 'terminal-ansi))) + (should (equal (cj/--face-diag-render-banner 'theme-faced) ""))) + +(ert-deftest test-face-diag-render-no-char () + "Boundary: a nil char group renders the no-character notice." + (should (string-match-p "none at point" (cj/--face-diag-render-char nil)))) + +(ert-deftest test-face-diag-render-region-covers-runs () + "Normal: region rendering emits a position header per distinct face-run." + (with-temp-buffer + (insert (propertize "aa" 'face 'bold)) + (insert (propertize "bb" 'face 'italic)) + (let ((report (cj/--face-diag-render-region (point-min) (point-max)))) + (should (string-match-p "=== position 1 ===" report)) + (should (string-match-p "=== position 3 ===" report))))) + +;;; cj/describe-face-at-point (smoke) + +(ert-deftest test-face-diag-command-creates-buffer () + "Normal: the command renders into the read-only *Face Diagnosis* buffer." + (with-temp-buffer + (insert (propertize "A" 'face 'bold)) + (goto-char (point-min)) + (cj/describe-face-at-point) + (let ((buf (get-buffer "*Face Diagnosis*"))) + (unwind-protect + (progn + (should buf) + (with-current-buffer buf + (should (eq major-mode 'cj/face-diagnostic-mode)) + (should buffer-read-only) + (should (string-match-p "Face stack" (buffer-string))))) + (when (buffer-live-p buf) (kill-buffer buf)))))) + +;;; keybinding + +(ert-deftest test-face-diag-bound-on-c-h-F () + "Normal: loading the module binds C-h F to the diagnostic command." + (should (eq (keymap-lookup help-map "F") 'cj/describe-face-at-point))) + +(provide 'test-face-diagnostic) +;;; test-face-diagnostic.el ends here diff --git a/tests/test-font-config--frame-lifecycle.el b/tests/test-font-config--frame-lifecycle.el new file mode 100644 index 000000000..826edbd69 --- /dev/null +++ b/tests/test-font-config--frame-lifecycle.el @@ -0,0 +1,75 @@ +;;; test-font-config--frame-lifecycle.el --- Tests for the lifted font frame helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/apply-font-settings-to-frame, cj/cleanup-frame-list, and +;; cj/maybe-install-all-the-icons-fonts were defined inside use-package +;; :config / with-eval-after-load (unreachable under `make test'). Lifting +;; them to top level makes their branching unit-testable; env-gui-p and the +;; package side-effect calls are mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'font-config) + +(defvar cj/fontaine-configured-frames) + +(ert-deftest test-font-cleanup-frame-list-removes-frame () + "Normal: cleanup drops the given frame from the configured list." + (let ((cj/fontaine-configured-frames '(fr1 fr2 fr3))) + (cj/cleanup-frame-list 'fr2) + (should (equal cj/fontaine-configured-frames '(fr1 fr3))))) + +(ert-deftest test-font-apply-gui-unconfigured-sets-preset () + "Normal: a GUI frame not yet configured gets the preset and is tracked." + (let ((cj/fontaine-configured-frames nil) + (called nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) + (cj/apply-font-settings-to-frame (selected-frame))) + (should called) + (should (member (selected-frame) cj/fontaine-configured-frames)))) + +(ert-deftest test-font-apply-already-configured-is-noop () + "Boundary: an already-configured frame is not re-preset." + (let ((cj/fontaine-configured-frames (list (selected-frame))) + (called nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) + (cj/apply-font-settings-to-frame (selected-frame))) + (should-not called))) + +(ert-deftest test-font-apply-non-gui-is-noop () + "Boundary: without a GUI nothing is applied or tracked." + (let ((cj/fontaine-configured-frames nil) + (called nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () nil)) + ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) + (cj/apply-font-settings-to-frame (selected-frame))) + (should-not called) + (should-not (member (selected-frame) cj/fontaine-configured-frames)))) + +(ert-deftest test-font-maybe-install-icons-gui-missing-installs () + "Normal: GUI present and font missing triggers the install." + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_n) nil)) + ((symbol-function 'all-the-icons-install-fonts) (lambda (&rest _) (setq installed t))) + ((symbol-function 'remove-hook) #'ignore)) + (cj/maybe-install-all-the-icons-fonts)) + (should installed))) + +(ert-deftest test-font-maybe-install-icons-already-present-skips () + "Boundary: an installed font means no install attempt." + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_n) t)) + ((symbol-function 'all-the-icons-install-fonts) (lambda (&rest _) (setq installed t)))) + (cj/maybe-install-all-the-icons-fonts)) + (should-not installed))) + +(provide 'test-font-config--frame-lifecycle) +;;; test-font-config--frame-lifecycle.el ends here diff --git a/tests/test-help-config.el b/tests/test-help-config.el new file mode 100644 index 000000000..0ba95c410 --- /dev/null +++ b/tests/test-help-config.el @@ -0,0 +1,32 @@ +;;; test-help-config.el --- Tests for the Info-open decision logic -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/open-with-info-mode opens the current .info buffer in Info, prompting to +;; save first if the buffer is modified. The save/cancel/open decision is +;; factored into the pure helper `cj/--info-open-plan' so it's testable without +;; driving find-file, Info, or the save prompt. Declining the prompt must yield +;; `cancel' -- the original cl-return-from inside a plain defun signalled +;; "No catch for tag" instead of cancelling. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'help-config) + +(ert-deftest test-info-open-plan-unmodified-opens () + "Normal: an unmodified buffer opens in Info directly." + (should (eq (cj/--info-open-plan nil nil) 'open))) + +(ert-deftest test-info-open-plan-modified-confirmed-saves-then-opens () + "Normal: a modified buffer whose save is confirmed saves, then opens." + (should (eq (cj/--info-open-plan t t) 'save-then-open))) + +(ert-deftest test-info-open-plan-modified-declined-cancels () + "Error/edge: a modified buffer whose save is declined cancels -- the path that +used to signal \"No catch for tag\" via cl-return-from in a plain defun." + (should (eq (cj/--info-open-plan t nil) 'cancel))) + +(provide 'test-help-config) +;;; test-help-config.el ends here diff --git a/tests/test-host-environment--detect-system-timezone.el b/tests/test-host-environment--detect-system-timezone.el index c24ac183a..1b5e61081 100644 --- a/tests/test-host-environment--detect-system-timezone.el +++ b/tests/test-host-environment--detect-system-timezone.el @@ -74,5 +74,30 @@ contents primitives." ((symbol-function 'file-symlink-p) (lambda (_) nil))) (should-not (cj/detect-system-timezone)))) +(ert-deftest test-host-environment-detect-tz-symlink-target-extracts-zone () + "Boundary: with methods 1-3 nil, a /etc/localtime symlink into zoneinfo +yields the zone after the /zoneinfo/ segment." + (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) + (lambda () nil)) + ((symbol-function 'getenv) (lambda (_) nil)) + ((symbol-function 'file-exists-p) (lambda (_) nil)) + ((symbol-function 'file-symlink-p) + (lambda (path) (string= path "/etc/localtime"))) + ((symbol-function 'file-truename) + (lambda (_) "/usr/share/zoneinfo/America/Denver"))) + (should (equal (cj/detect-system-timezone) "America/Denver")))) + +(ert-deftest test-host-environment-detect-tz-symlink-without-zoneinfo-is-nil () + "Error: a symlink target with no /zoneinfo/ segment yields nil." + (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) + (lambda () nil)) + ((symbol-function 'getenv) (lambda (_) nil)) + ((symbol-function 'file-exists-p) (lambda (_) nil)) + ((symbol-function 'file-symlink-p) + (lambda (path) (string= path "/etc/localtime"))) + ((symbol-function 'file-truename) + (lambda (_) "/var/lib/elsewhere/localtime"))) + (should-not (cj/detect-system-timezone)))) + (provide 'test-host-environment--detect-system-timezone) ;;; test-host-environment--detect-system-timezone.el ends here diff --git a/tests/test-init-module-headers.el b/tests/test-init-module-headers.el index bbda23887..a5b331f4d 100644 --- a/tests/test-init-module-headers.el +++ b/tests/test-init-module-headers.el @@ -2,7 +2,7 @@ ;;; Commentary: ;; Enforces the module load-graph header standard from -;; docs/design/init-load-graph.org against every module that has been +;; docs/specs/init-load-graph-spec-doing.org against every module that has been ;; classified so far. Classification proceeds in batches; a module joins ;; `test-init-header--classified-modules' once its header declares the ;; contract. When that list reaches parity with the modules required by diff --git a/tests/test-jumper--location-candidates.el b/tests/test-jumper--location-candidates.el new file mode 100644 index 000000000..df095830a --- /dev/null +++ b/tests/test-jumper--location-candidates.el @@ -0,0 +1,52 @@ +;;; test-jumper--location-candidates.el --- Tests for jumper--location-candidates -*- lexical-binding: t; -*- + +;;; Commentary: +;; jumper--location-candidates is the (display . index) builder extracted from +;; the verbatim cl-loop in jumper-jump-to-location and jumper-remove-location. +;; It composes jumper--format-location (which now goes through the extracted +;; jumper--with-marker-at). The wrappers cover it transitively; this exercises +;; it directly against stored locations. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'jumper) + +(ert-deftest test-jumper-location-candidates-one-pair-per-stored-location () + "Normal: one (display . index) pair per stored location, indices in order." + (let ((saved-regs jumper--registers) + (saved-idx jumper--next-index)) + (unwind-protect + (progn + (setq jumper--registers (make-vector jumper-max-locations nil) + jumper--next-index 0) + (with-temp-buffer + (insert "line one\nline two\nline three\n") + (goto-char (point-min)) + (should (integerp (jumper--do-store-location))) ; index 0 + (forward-line 2) + (should (integerp (jumper--do-store-location))) ; index 1 + (let ((cands (jumper--location-candidates))) + (should (= (length cands) 2)) + (should (equal (mapcar #'cdr cands) '(0 1))) + (should (stringp (car (nth 0 cands)))) + (should (stringp (car (nth 1 cands))))))) + (setq jumper--registers saved-regs + jumper--next-index saved-idx)))) + +(ert-deftest test-jumper-location-candidates-empty-when-none-stored () + "Boundary: no stored locations yields an empty candidate list." + (let ((saved-regs jumper--registers) + (saved-idx jumper--next-index)) + (unwind-protect + (progn + (setq jumper--registers (make-vector jumper-max-locations nil) + jumper--next-index 0) + (should (null (jumper--location-candidates)))) + (setq jumper--registers saved-regs + jumper--next-index saved-idx)))) + +(provide 'test-jumper--location-candidates) +;;; test-jumper--location-candidates.el ends here diff --git a/tests/test-keybindings-tty-mirror.el b/tests/test-keybindings-tty-mirror.el new file mode 100644 index 000000000..f63024c0b --- /dev/null +++ b/tests/test-keybindings-tty-mirror.el @@ -0,0 +1,33 @@ +;;; test-keybindings-tty-mirror.el --- TTY mirror prefix for the C-; family -*- lexical-binding: t; -*- + +;;; Commentary: +;; The personal prefix C-; is GUI-only — terminals can't encode Control-semicolon, +;; so the whole custom command family is unreachable in a TTY frame (emacs -nw, +;; emacsclient -nw, Emacs inside vterm/tmux). keybindings.el binds the single +;; `cj/custom-keymap' under a TTY-safe mirror prefix C-c ; alongside C-;, so the +;; same leaf keys reach the identical map in both GUI and terminal. These tests +;; pin that load-time global binding. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'keybindings) + +(ert-deftest test-keybindings-tty-mirror-gui-prefix-resolves () + "Normal: the GUI prefix C-; resolves to cj/custom-keymap globally." + (should (eq (keymap-lookup (current-global-map) "C-;") cj/custom-keymap))) + +(ert-deftest test-keybindings-tty-mirror-tty-prefix-resolves () + "Normal: the TTY mirror C-c ; resolves to the same cj/custom-keymap." + (should (eq (keymap-lookup (current-global-map) "C-c ;") cj/custom-keymap))) + +(ert-deftest test-keybindings-tty-mirror-both-prefixes-share-one-map () + "Boundary: both prefixes point at the identical keymap object, so a leaf +key registered once is reachable under either prefix." + (should (eq (keymap-lookup (current-global-map) "C-;") + (keymap-lookup (current-global-map) "C-c ;")))) + +(provide 'test-keybindings-tty-mirror) +;;; test-keybindings-tty-mirror.el ends here diff --git a/tests/test-local-repository--car-member.el b/tests/test-local-repository--car-member.el new file mode 100644 index 000000000..8b8c9a7db --- /dev/null +++ b/tests/test-local-repository--car-member.el @@ -0,0 +1,58 @@ +;;; test-local-repository--car-member.el --- Tests for car-member -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `car-member' in local-repository.el — the predicate +;; localrepo-initialize uses to check whether an archive id is already +;; registered in package-archives / package-archive-priorities. + +;;; Code: + +(require 'ert) +(require 'local-repository) + +;;; Normal Cases + +(ert-deftest test-local-repository-car-member-found () + "Normal: VALUE present as a car returns the matching tail (non-nil)." + (should (equal (car-member 'b '((a . 1) (b . 2) (c . 3))) + '(b c)))) + +(ert-deftest test-local-repository-car-member-not-found () + "Normal: VALUE absent from every car returns nil." + (should-not (car-member 'z '((a . 1) (b . 2))))) + +(ert-deftest test-local-repository-car-member-string-car () + "Normal: car comparison uses `equal', so string keys match by value." + (should (car-member "localrepo" + '(("gnu" . "url1") ("localrepo" . "url2"))))) + +;;; Boundary Cases + +(ert-deftest test-local-repository-car-member-empty-list () + "Boundary: an empty list never matches." + (should-not (car-member 'a nil))) + +(ert-deftest test-local-repository-car-member-single-match () + "Boundary: a single-element list whose car matches returns non-nil." + (should (car-member 'only '((only . 1))))) + +(ert-deftest test-local-repository-car-member-single-no-match () + "Boundary: a single-element list whose car differs returns nil." + (should-not (car-member 'x '((only . 1))))) + +(ert-deftest test-local-repository-car-member-nil-value-with-nil-car () + "Boundary: a nil VALUE matches a cons whose car is nil." + (should (car-member nil '((nil . 1) (a . 2))))) + +(ert-deftest test-local-repository-car-member-nil-value-no-nil-car () + "Boundary: a nil VALUE with no nil car returns nil." + (should-not (car-member nil '((a . 1) (b . 2))))) + +;;; Error Cases + +(ert-deftest test-local-repository-car-member-non-cons-element () + "Error: a non-cons element makes `car' signal wrong-type-argument." + (should-error (car-member 'x '(1 2)) :type 'wrong-type-argument)) + +(provide 'test-local-repository--car-member) +;;; test-local-repository--car-member.el ends here diff --git a/tests/test-mail-config--account-search-queries.el b/tests/test-mail-config--account-search-queries.el new file mode 100644 index 000000000..9f1b6b3e6 --- /dev/null +++ b/tests/test-mail-config--account-search-queries.el @@ -0,0 +1,53 @@ +;;; test-mail-config--account-search-queries.el --- Tests for the mail account-nav helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--mail-account-search-queries (pure: account name -> the four mu4e search +;; strings) and cj/--mail-make-account-map (builds the per-account nav keymap) +;; replace three near-identical defvar-keymap blocks that differed only by +;; maildir prefix. The map test invokes each binding with mu4e-search mocked, +;; which also verifies each loop-built closure captured its own query. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'mail-config) + +(ert-deftest test-mail-account-search-queries-cmail () + "Normal: the four searches are scoped to the account's INBOX maildir." + (should (equal (cj/--mail-account-search-queries "cmail") + '(("i" . "maildir:/cmail/INBOX") + ("u" . "maildir:/cmail/INBOX AND flag:unread AND NOT flag:trashed") + ("s" . "maildir:/cmail/INBOX AND flag:flagged") + ("l" . "maildir:/cmail/INBOX AND size:5M..999M"))))) + +(ert-deftest test-mail-account-search-queries-prefix-varies () + "Boundary: only the maildir prefix changes between accounts." + (should (equal (cdr (assoc "i" (cj/--mail-account-search-queries "dmail"))) + "maildir:/dmail/INBOX")) + (should (equal (cdr (assoc "i" (cj/--mail-account-search-queries "gmail"))) + "maildir:/gmail/INBOX"))) + +(ert-deftest test-mail-make-account-map-binds-four-keys () + "Normal: the built keymap binds i/u/s/l to commands." + (let ((map (cj/--mail-make-account-map "cmail"))) + (dolist (key '("i" "u" "s" "l")) + (should (commandp (keymap-lookup map key)))))) + +(ert-deftest test-mail-make-account-map-closures-capture-distinct-queries () + "Normal: each binding runs its own account-scoped search (no closure leak). +mu4e-search is mocked to capture the query each command passes." + (let ((searched '())) + (cl-letf (((symbol-function 'mu4e-search) + (lambda (q) (push q searched)))) + (let ((map (cj/--mail-make-account-map "dmail"))) + (funcall (keymap-lookup map "i")) + (funcall (keymap-lookup map "u")))) + (should (member "maildir:/dmail/INBOX" searched)) + (should (member "maildir:/dmail/INBOX AND flag:unread AND NOT flag:trashed" + searched)))) + +(provide 'test-mail-config--account-search-queries) +;;; test-mail-config--account-search-queries.el ends here diff --git a/tests/test-mail-config-refile-folder.el b/tests/test-mail-config-refile-folder.el new file mode 100644 index 000000000..e2d224eb6 --- /dev/null +++ b/tests/test-mail-config-refile-folder.el @@ -0,0 +1,40 @@ +;;; test-mail-config-refile-folder.el --- Tests for refile-folder dispatch -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/mu4e--refile-folder-for-maildir', the per-message refile +;; (archive) target dispatch. cmail has a real synced Archive folder; the +;; Gmail-backed accounts (gmail, dmail) have none, so refiling them must signal +;; rather than move mail into an unsynced, phantom folder (silent mail loss). + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'mail-config) + +(ert-deftest test-mail-config-refile-cmail-returns-archive () + "Normal: a cmail message refiles into the synced /cmail/Archive folder." + (should (string= (cj/mu4e--refile-folder-for-maildir "/cmail/INBOX") + "/cmail/Archive")) + (should (string= (cj/mu4e--refile-folder-for-maildir "/cmail/Sent") + "/cmail/Archive"))) + +(ert-deftest test-mail-config-refile-gmail-signals () + "Error: gmail has no synced archive folder, so refile signals rather than +moving mail into a phantom folder." + (should-error (cj/mu4e--refile-folder-for-maildir "/gmail/INBOX") + :type 'user-error)) + +(ert-deftest test-mail-config-refile-dmail-signals () + "Error: dmail (Gmail-backed) has no synced archive folder; refile signals." + (should-error (cj/mu4e--refile-folder-for-maildir "/dmail/INBOX") + :type 'user-error)) + +(ert-deftest test-mail-config-refile-nil-maildir-signals () + "Boundary: a message with no maildir cannot be refiled; signal." + (should-error (cj/mu4e--refile-folder-for-maildir nil) + :type 'user-error)) + +(provide 'test-mail-config-refile-folder) +;;; test-mail-config-refile-folder.el ends here diff --git a/tests/test-markdown-config.el b/tests/test-markdown-config.el index 45e1a6018..edb20d357 100644 --- a/tests/test-markdown-config.el +++ b/tests/test-markdown-config.el @@ -9,6 +9,7 @@ ;;; Code: (require 'ert) +(require 'cl-lib) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) @@ -50,5 +51,14 @@ (should (string-match-p "<xmp" (buffer-string)))) (kill-buffer src)))) +;;; cj/markdown-preview (guard: refuse when the httpd listener is down) + +(ert-deftest test-markdown-preview-errors-when-server-down () + "Error: `cj/markdown-preview' signals a user-error when the simple-httpd +listener is not running, rather than opening a preview against a dead server. +Also pins the rename off the bare `markdown-preview' that markdown-mode shadows." + (cl-letf (((symbol-function 'httpd-running-p) (lambda () nil))) + (should-error (cj/markdown-preview) :type 'user-error))) + (provide 'test-markdown-config) ;;; test-markdown-config.el ends here diff --git a/tests/test-modeline-config--click-map.el b/tests/test-modeline-config--click-map.el new file mode 100644 index 000000000..6c5ba4c7e --- /dev/null +++ b/tests/test-modeline-config--click-map.el @@ -0,0 +1,29 @@ +;;; test-modeline-config--click-map.el --- Tests for cj/--modeline-click-map -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--modeline-click-map is the shared mode-line `local-map' builder extracted +;; from three clickable segments (buffer-name, vc, major-mode) that each spelled +;; out the same make-sparse-keymap + define-key dance. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'modeline-config) + +(ert-deftest test-modeline-click-map-binds-mouse-1-and-3 () + "Normal: with both commands, mouse-1 and mouse-3 are bound." + (let ((map (cj/--modeline-click-map 'vc-diff 'vc-root-diff))) + (should (keymapp map)) + (should (eq (lookup-key map [mode-line mouse-1]) 'vc-diff)) + (should (eq (lookup-key map [mode-line mouse-3]) 'vc-root-diff)))) + +(ert-deftest test-modeline-click-map-mouse-1-only () + "Boundary: with no MOUSE-3, only mouse-1 is bound." + (let ((map (cj/--modeline-click-map 'describe-mode))) + (should (eq (lookup-key map [mode-line mouse-1]) 'describe-mode)) + (should (null (lookup-key map [mode-line mouse-3]))))) + +(provide 'test-modeline-config--click-map) +;;; test-modeline-config--click-map.el ends here diff --git a/tests/test-modeline-config-flycheck-segment.el b/tests/test-modeline-config-flycheck-segment.el index 208deaa72..2ae2f5de1 100644 --- a/tests/test-modeline-config-flycheck-segment.el +++ b/tests/test-modeline-config-flycheck-segment.el @@ -5,7 +5,7 @@ ;; a guarded reference to `flycheck-mode-line-status-text', and that ;; the guard requires both `mode-line-window-selected-p' and ;; `bound-and-true-p flycheck-mode'. See -;; docs/design/flycheck-modeline-customization.org for the design. +;; docs/specs/flycheck-modeline-customization-spec-implemented.org for the design. ;;; Code: diff --git a/tests/test-modeline-config-string-cut-middle.el b/tests/test-modeline-config-string-cut-middle.el index 40cc0bccc..d68431b49 100644 --- a/tests/test-modeline-config-string-cut-middle.el +++ b/tests/test-modeline-config-string-cut-middle.el @@ -17,14 +17,6 @@ ;; Add modules directory to load path (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -;; Stub dependencies before loading the module -(unless (boundp 'cj/buffer-status-colors) - (defvar cj/buffer-status-colors - '((unmodified . "#FFFFFF") - (modified . "#00FF00") - (read-only . "#FF0000") - (overwrite . "#FFD700")))) - (require 'modeline-config) ;;; Test Helpers diff --git a/tests/test-modeline-config-string-truncate-p.el b/tests/test-modeline-config-string-truncate-p.el index 09378b0d1..94ea74171 100644 --- a/tests/test-modeline-config-string-truncate-p.el +++ b/tests/test-modeline-config-string-truncate-p.el @@ -19,14 +19,6 @@ ;; Add modules directory to load path (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -;; Stub dependencies before loading the module -(unless (boundp 'cj/buffer-status-colors) - (defvar cj/buffer-status-colors - '((unmodified . "#FFFFFF") - (modified . "#00FF00") - (read-only . "#FF0000") - (overwrite . "#FFD700")))) - (require 'modeline-config) ;;; Test Helpers diff --git a/tests/test-modeline-config-vc-cache-key.el b/tests/test-modeline-config-vc-cache-key.el index ae869f4b8..6ba7985c2 100644 --- a/tests/test-modeline-config-vc-cache-key.el +++ b/tests/test-modeline-config-vc-cache-key.el @@ -1,56 +1,36 @@ ;;; test-modeline-config-vc-cache-key.el --- Tests for VC modeline cache key -*- lexical-binding: t; -*- ;;; Commentary: -;; The VC modeline cache keys on the file. A symlink whose target moves to a -;; different VC tree must invalidate the cache, so the key includes the -;; resolved `file-truename', not just the symlink path. +;; The VC modeline cache keys on the file path and the `cj/modeline-vc-show-remote' +;; flag only. `file-truename' is deliberately NOT in the key: it would run on +;; every redisplay (the mode-line rebuilds the key each render to check validity), +;; and a moved symlink target is picked up at the next TTL refresh anyway, since +;; `vc-backend' resolves the link fresh. The per-render stat isn't worth it. ;;; Code: (require 'ert) -(require 'cl-lib) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'modeline-config) -;;; Normal Cases - -(ert-deftest test-modeline-vc-cache-key-includes-truename () - "Normal: the cache key includes the resolved truename of the file." - (let ((f (make-temp-file "cj-mlkey-"))) - (unwind-protect - (should (member (file-truename f) (cj/modeline-vc-cache-key f))) - (delete-file f)))) - -;;; Boundary Cases - -(ert-deftest test-modeline-vc-cache-key-changes-when-symlink-target-moves () - "Boundary: re-pointing a symlink to a new target changes the cache key. -The symlink path is identical both times; only its truename differs, so a -key that ignored the truename would serve a stale VC backend." - (let* ((dir (make-temp-file "cj-mlkey-dir-" t)) - (target-a (expand-file-name "a" dir)) - (target-b (expand-file-name "b" dir)) - (link (expand-file-name "link" dir))) - (unwind-protect - (progn - (write-region "" nil target-a) - (write-region "" nil target-b) - (make-symbolic-link target-a link) - (let ((key-a (cj/modeline-vc-cache-key link))) - (delete-file link) - (make-symbolic-link target-b link) - (let ((key-b (cj/modeline-vc-cache-key link))) - (should-not (equal key-a key-b))))) - (delete-directory dir t)))) +(ert-deftest test-modeline-vc-cache-key-is-file-and-show-remote () + "Normal: the key is (FILE SHOW-REMOTE), with no per-render file-truename stat." + (let ((cj/modeline-vc-show-remote nil)) + (should (equal (cj/modeline-vc-cache-key "/x/y.el") '("/x/y.el" nil))))) + +(ert-deftest test-modeline-vc-cache-key-tracks-show-remote () + "Boundary: toggling show-remote yields a different key (separate cache entry)." + (should-not (equal (let ((cj/modeline-vc-show-remote nil)) + (cj/modeline-vc-cache-key "/x/y.el")) + (let ((cj/modeline-vc-show-remote t)) + (cj/modeline-vc-cache-key "/x/y.el"))))) (ert-deftest test-modeline-vc-cache-key-stable-for-same-file () - "Boundary: the key is stable across calls for an unchanged file." - (let ((f (make-temp-file "cj-mlkey-stable-"))) - (unwind-protect - (should (equal (cj/modeline-vc-cache-key f) - (cj/modeline-vc-cache-key f))) - (delete-file f)))) + "Boundary: the key is stable across calls for an unchanged file + show-remote." + (let ((cj/modeline-vc-show-remote nil)) + (should (equal (cj/modeline-vc-cache-key "/x/y.el") + (cj/modeline-vc-cache-key "/x/y.el"))))) (provide 'test-modeline-config-vc-cache-key) ;;; test-modeline-config-vc-cache-key.el ends here diff --git a/tests/test-modeline-config-vc-cache.el b/tests/test-modeline-config-vc-cache.el index b6aafbfbe..dab755442 100644 --- a/tests/test-modeline-config-vc-cache.el +++ b/tests/test-modeline-config-vc-cache.el @@ -98,5 +98,12 @@ (should (text-property-any 0 (length rendered) 'mouse-face 'mode-line-highlight rendered))))) +(ert-deftest test-modeline-config-vc-fetch-swallows-vc-errors () + "Error: a signal from the VC backend is swallowed (returns nil) rather than +propagating into the mode-line redisplay path, where it would break all redisplay." + (cl-letf (((symbol-function 'file-remote-p) (lambda (&rest _) nil)) + ((symbol-function 'vc-backend) (lambda (&rest _) (error "git boom")))) + (should (null (cj/modeline-vc-fetch "/tmp/project/file.el"))))) + (provide 'test-modeline-config-vc-cache) ;;; test-modeline-config-vc-cache.el ends here diff --git a/tests/test-mousetrap-mode--bind-events.el b/tests/test-mousetrap-mode--bind-events.el new file mode 100644 index 000000000..6772d6fa3 --- /dev/null +++ b/tests/test-mousetrap-mode--bind-events.el @@ -0,0 +1,41 @@ +;;; test-mousetrap-mode--bind-events.el --- Tests for mouse-trap--bind-events-to-ignore -*- lexical-binding: t; -*- + +;;; Commentary: +;; mouse-trap--bind-events-to-ignore is the per-category binding loop extracted +;; from mouse-trap--build-keymap-1 (which previously nested it five deep). It +;; binds a category's events, across modifier prefixes, to `ignore'. The full +;; keymap build stays covered by test-mousetrap-mode--build-keymap.el. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'mousetrap-mode) + +(ert-deftest test-mousetrap-bind-events-wheel () + "Normal: wheel events are bound to ignore across every prefix variant." + (let ((map (make-sparse-keymap)) + (spec '((wheel . ("wheel-up" "wheel-down"))))) + (mouse-trap--bind-events-to-ignore spec '("" "C-") map) + (should (eq (lookup-key map (kbd "<wheel-up>")) #'ignore)) + (should (eq (lookup-key map (kbd "<C-wheel-up>")) #'ignore)) + (should (eq (lookup-key map (kbd "<wheel-down>")) #'ignore)))) + +(ert-deftest test-mousetrap-bind-events-click () + "Normal: type x button click events are bound to ignore." + (let ((map (make-sparse-keymap)) + (spec '((types . ("mouse" "down-mouse")) (buttons . (1 3))))) + (mouse-trap--bind-events-to-ignore spec '("") map) + (should (eq (lookup-key map (kbd "<mouse-1>")) #'ignore)) + (should (eq (lookup-key map (kbd "<mouse-3>")) #'ignore)) + (should (eq (lookup-key map (kbd "<down-mouse-1>")) #'ignore)))) + +(ert-deftest test-mousetrap-bind-events-empty-spec-no-op () + "Boundary: a spec with neither wheel nor types/buttons binds nothing." + (let ((map (make-sparse-keymap))) + (mouse-trap--bind-events-to-ignore '((other . t)) '("") map) + (should (null (lookup-key map (kbd "<mouse-1>")))))) + +(provide 'test-mousetrap-mode--bind-events) +;;; test-mousetrap-mode--bind-events.el ends here diff --git a/tests/test-music-config--playlist-side.el b/tests/test-music-config--playlist-side.el new file mode 100644 index 000000000..f49694690 --- /dev/null +++ b/tests/test-music-config--playlist-side.el @@ -0,0 +1,45 @@ +;;; test-music-config--playlist-side.el --- Tests for the F10 dock-side helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--music-playlist-side' maps the shared dock rule's verdict to a +;; `display-buffer-in-side-window' side: `right' stays `right', anything +;; else becomes `bottom'. The decision itself lives in +;; `cj/preferred-dock-direction' (tested in test-cj-window-geometry-lib.el); +;; here we stub it (an ordinary defun -- safe to `cl-letf', unlike the +;; frame-* subrs) to prove the mapping and that the width fraction is +;; passed through. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'music-config) + +(ert-deftest test-music-config--playlist-side-right-verdict-is-right () + "Normal: a `right' verdict from the dock rule docks the playlist right." + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (&rest _) 'right))) + (should (eq (cj/--music-playlist-side) 'right)))) + +(ert-deftest test-music-config--playlist-side-below-verdict-is-bottom () + "Normal: a `below' verdict maps to the `bottom' side window." + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (&rest _) 'below))) + (should (eq (cj/--music-playlist-side) 'bottom)))) + +(ert-deftest test-music-config--playlist-side-passes-width-fraction () + "Normal: the playlist's width fraction reaches the dock rule." + (let ((cj/music-playlist-window-width 0.4) + captured) + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (cols frac &rest _) + (setq captured (list cols frac)) + 'below))) + (cj/--music-playlist-side) + (should (= (nth 1 captured) 0.4)) + (should (integerp (nth 0 captured)))))) + +(provide 'test-music-config--playlist-side) +;;; test-music-config--playlist-side.el ends here diff --git a/tests/test-org-agenda-config--base-files.el b/tests/test-org-agenda-config--base-files.el new file mode 100644 index 000000000..c6939b4d7 --- /dev/null +++ b/tests/test-org-agenda-config--base-files.el @@ -0,0 +1,36 @@ +;;; test-org-agenda-config--base-files.el --- Tests for the agenda base-file helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--org-agenda-base-files is the single source of the fixed agenda base list +;; (inbox, schedule, and the three calendars) that was previously spelled out as +;; a literal in three places. The path vars are special (defvar'd in +;; user-constants), so they can be dynamically bound here. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-agenda-config) + +(ert-deftest test-org-agenda-base-files-returns-fixed-list-in-order () + "Normal: returns inbox, schedule, gcal, pcal, dcal in that order." + (let ((inbox-file "/i") + (schedule-file "/s") + (gcal-file "/g") + (pcal-file "/p") + (dcal-file "/d")) + (should (equal (cj/--org-agenda-base-files) + '("/i" "/s" "/g" "/p" "/d"))))) + +(ert-deftest test-org-agenda-base-files-reflects-current-values () + "Boundary: the helper reads the vars at call time (not a captured snapshot)." + (let ((inbox-file "first") + (schedule-file "x") (gcal-file "x") (pcal-file "x") (dcal-file "x")) + (should (equal (car (cj/--org-agenda-base-files)) "first")) + (setq inbox-file "second") + (should (equal (car (cj/--org-agenda-base-files)) "second")) + (should (= (length (cj/--org-agenda-base-files)) 5)))) + +(provide 'test-org-agenda-config--base-files) +;;; test-org-agenda-config--base-files.el ends here diff --git a/tests/test-org-agenda-config-commands.el b/tests/test-org-agenda-config-commands.el index e29871b79..76407439d 100644 --- a/tests/test-org-agenda-config-commands.el +++ b/tests/test-org-agenda-config-commands.el @@ -145,6 +145,24 @@ calling `org-agenda'." (should build-called) (should (equal agenda-args '("a" "d"))))) +;;; org-agenda-custom-commands "d" daily structure + +(defun test-org-agenda--daily-blocks () + "Return the block list of the \"d\" daily agenda command." + (nth 2 (assoc "d" org-agenda-custom-commands))) + +(ert-deftest test-org-agenda-daily-schedule-block-is-first () + "Normal: the schedule (calendar) block leads the daily agenda." + (should (eq (car (nth 0 (test-org-agenda--daily-blocks))) 'agenda))) + +(ert-deftest test-org-agenda-daily-has-no-overdue-block () + "Normal: no overdue block. It duplicated the past-due +scheduled/deadline items the schedule block already surfaces on +today's line (org-scheduled-past-days/org-deadline-past-days are +large), so the standalone OVERDUE section was redundant." + (let ((flat (flatten-tree (test-org-agenda--daily-blocks)))) + (should-not (memq 'cj/org-agenda-skip-subtree-if-not-overdue flat)))) + ;;; cj/add-timestamp-to-org-entry (ert-deftest test-org-agenda-add-timestamp-inserts-on-next-line () diff --git a/tests/test-org-agenda-config-skip-functions.el b/tests/test-org-agenda-config-skip-functions.el index aec1e71be..b8290da21 100644 --- a/tests/test-org-agenda-config-skip-functions.el +++ b/tests/test-org-agenda-config-skip-functions.el @@ -145,76 +145,6 @@ Suppresses org-mode hooks to avoid loading packages not available in batch." (test-org-agenda--with-org-buffer "* DONE Finished task\n" (should (integerp (cj/org-skip-subtree-if-keyword '("TODO" "DONE" "CANCELLED")))))) -;;; ---------- cj/org-agenda-skip-subtree-if-not-overdue ---------- - -;;; Normal Cases - -(ert-deftest test-org-agenda-config-skip-overdue-normal-past-scheduled-keeps () - "Entry scheduled in the past with TODO keyword is overdue — keep it." - (test-org-agenda--with-org-buffer - (concat "* TODO Overdue task\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n") - (should (null (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-future-scheduled-skips () - "Entry scheduled in the future is not overdue — skip it." - (test-org-agenda--with-org-buffer - (concat "* TODO Future task\n" - "SCHEDULED: " (test-org-timestamp-days-ahead 7) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-past-deadline-keeps () - "Entry with past deadline and TODO keyword is overdue — keep it." - (test-org-agenda--with-org-buffer - (concat "* TODO Missed deadline\n" - "DEADLINE: " (test-org-timestamp-days-ago 3) "\n") - (should (null (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-done-task-skips () - "Done task should be skipped even if overdue." - (test-org-agenda--with-org-buffer - (concat "* DONE Completed task\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-habit-skips () - "Habit should be skipped even if overdue." - (test-org-agenda--with-org-buffer - (concat "* TODO Daily habit\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n" - ":PROPERTIES:\n" - ":STYLE: habit\n" - ":END:\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-no-todo-keyword-skips () - "Entry without a TODO keyword should be skipped." - (test-org-agenda--with-org-buffer - (concat "* Just a heading\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -;;; Boundary Cases - -(ert-deftest test-org-agenda-config-skip-overdue-boundary-today-scheduled-skips () - "Entry scheduled today is NOT overdue (not strictly before today) — skip." - (test-org-agenda--with-org-buffer - (concat "* TODO Today task\n" - "SCHEDULED: " (test-org-timestamp-today) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-boundary-no-date-skips () - "Entry with TODO but no scheduled/deadline date — not overdue, skip." - (test-org-agenda--with-org-buffer "* TODO Undated task\n" - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-boundary-future-deadline-skips () - "Entry with future deadline is not overdue — skip." - (test-org-agenda--with-org-buffer - (concat "* TODO Future deadline\n" - "DEADLINE: " (test-org-timestamp-days-ahead 14) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - ;;; ---------- "d" command SCHEDULE block: CANCELLED skip ---------- ;;; Normal Cases @@ -268,17 +198,18 @@ regression where one block diverges from the others on the format." ;;; Normal Cases -(ert-deftest test-org-agenda-config-d-command-has-six-blocks-in-expected-order () - "Normal: the \"d\" command runs six blocks in the expected order -- -OVERDUE -> HIGH PRIORITY -> VERIFICATION -> SCHEDULE -> IN-PROGRESS -> PRIORITY B." +(ert-deftest test-org-agenda-config-d-command-has-five-blocks-in-expected-order () + "Normal: the \"d\" command runs five blocks in the expected order -- +SCHEDULE -> HIGH PRIORITY -> VERIFICATION -> IN-PROGRESS -> PRIORITY B. +The schedule (calendar) leads; the former OVERDUE block was dropped +because it duplicated the past-due items the schedule already shows." (let* ((entry (assoc "d" org-agenda-custom-commands)) (blocks (nth 2 entry)) (shapes (mapcar (lambda (b) (list (car b) (cadr b))) blocks))) (should (equal shapes - '((alltodo "") + '((agenda "") (tags "PRIORITY=\"A\"") (todo "VERIFY") - (agenda "") (todo "DOING") (alltodo "")))))) diff --git a/tests/test-org-capture-config--find-or-create-top-heading.el b/tests/test-org-capture-config--find-or-create-top-heading.el new file mode 100644 index 000000000..236c87c87 --- /dev/null +++ b/tests/test-org-capture-config--find-or-create-top-heading.el @@ -0,0 +1,45 @@ +;;; test-org-capture-config--find-or-create-top-heading.el --- Tests for the shared find-or-create helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--org-find-or-create-top-heading is the search-or-append positioning block +;; extracted from cj/org-capture--goto-file-headline, cj/--org-capture-goto-open-work, +;; and cj/--org-capture-goto-exact-headline. The three call sites stay covered by +;; test-org-capture-config-project-target.el (open-work, exact-headline) and the +;; target-cache test; these cover the generic helper directly with a plain regexp +;; (so the test doesn't depend on org's complex-heading format). + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-capture-config) + +(ert-deftest test-org-find-or-create-top-heading-finds-existing () + "Normal: an existing heading is found; point lands at its line start and the +buffer is unchanged." + (with-temp-buffer + (insert "* Alpha\nbody\n* Target\nmore\n") + (cj/--org-find-or-create-top-heading "^\\* Target$" "* Target") + (should (looking-at-p "\\* Target$")) + (should (equal (buffer-string) "* Alpha\nbody\n* Target\nmore\n")))) + +(ert-deftest test-org-find-or-create-top-heading-creates-when-absent () + "Boundary: with no match, the heading line is appended (a separating newline +added because the buffer doesn't end in one) and point lands on it." + (with-temp-buffer + (insert "some text") ; no trailing newline + (cj/--org-find-or-create-top-heading "^\\* Missing$" "* Missing") + (should (equal (buffer-string) "some text\n* Missing\n")) + (should (looking-at-p "\\* Missing$")))) + +(ert-deftest test-org-find-or-create-top-heading-empty-buffer () + "Boundary: in an empty buffer the heading is inserted at the top, no extra +leading newline." + (with-temp-buffer + (cj/--org-find-or-create-top-heading "^\\* X$" "* X") + (should (equal (buffer-string) "* X\n")) + (should (looking-at-p "\\* X$")))) + +(provide 'test-org-capture-config--find-or-create-top-heading) +;;; test-org-capture-config--find-or-create-top-heading.el ends here diff --git a/tests/test-org-capture-config-popup-window.el b/tests/test-org-capture-config-popup-window.el index 34f67b36e..d308fc2b7 100644 --- a/tests/test-org-capture-config-popup-window.el +++ b/tests/test-org-capture-config-popup-window.el @@ -1,13 +1,12 @@ -;;; test-org-capture-config-popup-window.el --- Quick-capture popup single-window tests -*- lexical-binding: t; -*- +;;; test-org-capture-config-popup-window.el --- Quick-capture popup tests -*- lexical-binding: t; -*- ;;; Commentary: -;; Tests for the pure predicate behind the quick-capture popup single-window -;; fix. The Hyprland Super+Shift+N popup opens an emacsclient frame named -;; "org-capture"; in that frame the *Org Select* template menu and the -;; CAPTURE-* buffer must fill the frame's sole window instead of splitting it. -;; `cj/org-capture--popup-sole-window-p' is the frame+buffer decision; the -;; display-buffer action that acts on it is exercised by hand (window ops), -;; not here. +;; Tests for the Hyprland Super+Shift+N quick-capture popup. The popup opens an +;; emacsclient frame named "org-capture" and runs `cj/quick-capture', which +;; captures a single Task into the global inbox with no template menu. Covered +;; here: the sole-window predicate and display action (the CAPTURE-* buffer +;; fills the frame), the single-Task template builder, frame discovery and focus +;; (the emacsclient focus race), and frame cleanup on every exit path. ;;; Code: @@ -19,18 +18,6 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'org-capture-config) -(defconst test-org-capture-popup--sample-templates - '(("t" "Task" entry (function cj/--org-capture-project-location) - "* TODO %?" :prepend t) - ("b" "Bug" entry (function cj/--org-capture-project-location) - "* TODO [#C] %?" :prepend t) - ("e" "Event" entry (file+headline schedule-file "Scheduled Events") - "* %?" :prepend t :prepare-finalize cj/org-capture-format-event-headline) - ("m" "Mu4e Email" entry (file+headline inbox-file "Inbox") "* TODO %?" :prepend t) - ("L" "Link" entry (file+headline inbox-file "Inbox") "* %?" :immediate-finish t) - ("d" "Drill Question" entry (file ignore) "* Item :drill:\n%?" :prepend t)) - "A representative org-capture-templates list for popup-subset tests.") - ;;; cj/org-capture--popup-sole-window-p (ert-deftest test-org-capture-config-popup-sole-window-p-select-menu () @@ -73,9 +60,6 @@ Components integrated: - display-buffer / display-buffer-alist (real) Validates the popup frame ends with one window showing the CAPTURE buffer." - ;; The batch frame is auto-named (\"F1\"), which cannot be restored by name - ;; (\"F<num> usurped by Emacs\"); reset to nil to return it to auto-naming, - ;; keeping the test independent of execution order. (let ((buf (get-buffer-create "CAPTURE-itest"))) (unwind-protect (progn @@ -87,76 +71,47 @@ Validates the popup frame ends with one window showing the CAPTURE buffer." (set-frame-parameter nil 'name nil) (when (buffer-live-p buf) (kill-buffer buf))))) -;;; cj/--org-capture-popup-templates (pure subset/retarget) - -(ert-deftest test-org-capture-config-popup-templates-keeps-tbe () - "Normal: only Task, Bug, Event survive, preserving order." - (should (equal (mapcar #'car (cj/--org-capture-popup-templates - test-org-capture-popup--sample-templates "/inbox.org")) - '("t" "b" "e")))) +;;; cj/--quick-capture-template (single Task into the inbox) -(ert-deftest test-org-capture-config-popup-templates-retargets-task-bug () - "Normal: Task and Bug retarget to the inbox \"Inbox\" headline; body + props kept." - (let* ((result (cj/--org-capture-popup-templates - test-org-capture-popup--sample-templates "/inbox.org")) - (task (assoc "t" result)) - (bug (assoc "b" result))) +(ert-deftest test-org-capture-config-quick-capture-template () + "Normal: the quick-capture template is a single Task into INBOX's Inbox." + (let* ((tmpl (cj/--quick-capture-template "/inbox.org")) + (task (assoc "t" tmpl))) + (should (equal (mapcar #'car tmpl) '("t"))) + (should (equal (nth 1 task) "Task")) + (should (eq (nth 2 task) 'entry)) (should (equal (nth 3 task) '(file+headline "/inbox.org" "Inbox"))) - (should (equal (nth 3 bug) '(file+headline "/inbox.org" "Inbox"))) (should (equal (nth 4 task) "* TODO %?")) - (should (equal (nth 4 bug) "* TODO [#C] %?")) (should (memq :prepend task)))) -(ert-deftest test-org-capture-config-popup-templates-event-unchanged () - "Boundary: Event passes through untouched, schedule-file target and props intact." - (let ((event (assoc "e" (cj/--org-capture-popup-templates - test-org-capture-popup--sample-templates "/inbox.org")))) - (should (equal (nth 3 event) '(file+headline schedule-file "Scheduled Events"))) - (should (memq :prepare-finalize event)))) - -(ert-deftest test-org-capture-config-popup-templates-drops-context-templates () - "Boundary: context-dependent templates (mu4e, link, drill) are dropped." - (let ((result (cj/--org-capture-popup-templates - test-org-capture-popup--sample-templates "/inbox.org"))) - (should-not (assoc "m" result)) - (should-not (assoc "L" result)) - (should-not (assoc "d" result)))) - -(ert-deftest test-org-capture-config-popup-templates-empty () - "Error/Boundary: empty or all-dropped input yields nil without raising." - (should-not (cj/--org-capture-popup-templates nil "/inbox.org")) - (should-not (cj/--org-capture-popup-templates - '(("L" "Link" entry (file+headline f "Inbox") "* %?")) "/inbox.org"))) - -;;; cj/quick-capture (binds the subset; integration with a stubbed org-capture) - -(ert-deftest test-integration-org-capture-quick-capture-binds-subset () - "Integration: cj/quick-capture runs org-capture with only Task/Bug/Event, -Task and Bug retargeted to the inbox. +;;; cj/quick-capture (single Task; stubbed org-capture) + +(ert-deftest test-integration-org-capture-quick-capture-binds-task-only () + "Integration: cj/quick-capture runs org-capture with a single Task template +targeting the inbox, dispatched by key. Components integrated: - cj/quick-capture (real) -- cj/--org-capture-popup-templates (real) -- org-capture (MOCKED — records the dynamically-bound templates)" - (let ((org-capture-templates test-org-capture-popup--sample-templates) - captured) +- cj/--quick-capture-template (real) +- org-capture (MOCKED — records the bound templates and dispatch key)" + (let (captured key) (cl-letf (((symbol-function 'org-capture) - (lambda (&rest _) (setq captured org-capture-templates)))) + (lambda (&optional _goto k) (setq captured org-capture-templates key k)))) (cj/quick-capture)) - (should (equal (mapcar #'car captured) '("t" "b" "e"))) + (should (equal (mapcar #'car captured) '("t"))) (should (equal (nth 3 (assoc "t" captured)) (list 'file+headline inbox-file "Inbox"))) - (should (equal (nth 3 (assoc "b" captured)) (list 'file+headline inbox-file "Inbox"))))) + (should (equal (nth 4 (assoc "t" captured)) "* TODO %?")) + (should (equal key "t")))) (ert-deftest test-integration-org-capture-quick-capture-closes-frame-on-abort () - "Integration: when selection aborts (org-capture signals), cj/quick-capture + "Integration: when capture aborts (org-capture signals), cj/quick-capture deletes the popup frame instead of leaving it orphaned. Components integrated: - cj/quick-capture (real) - org-capture (MOCKED — signals user-error \"Abort\") - cj/org-capture--delete-popup-frame (MOCKED — records the call)" - (let ((org-capture-templates test-org-capture-popup--sample-templates) - (deleted 0)) + (let ((deleted 0)) (cl-letf (((symbol-function 'org-capture) (lambda (&rest _) (user-error "Abort"))) ((symbol-function 'cj/org-capture--delete-popup-frame) @@ -166,8 +121,7 @@ Components integrated: (ert-deftest test-integration-org-capture-quick-capture-closes-frame-on-quit () "Integration: a C-g (quit) during capture also closes the popup frame." - (let ((org-capture-templates test-org-capture-popup--sample-templates) - (deleted 0)) + (let ((deleted 0)) (cl-letf (((symbol-function 'org-capture) (lambda (&rest _) (signal 'quit nil))) ((symbol-function 'cj/org-capture--delete-popup-frame) @@ -178,31 +132,13 @@ Components integrated: (ert-deftest test-integration-org-capture-quick-capture-keeps-frame-on-success () "Integration: a successful capture (no signal) does NOT delete the frame — the finalize hook owns that." - (let ((org-capture-templates test-org-capture-popup--sample-templates) - (deleted 0)) + (let ((deleted 0)) (cl-letf (((symbol-function 'org-capture) (lambda (&rest _) nil)) ((symbol-function 'cj/org-capture--delete-popup-frame) (lambda () (cl-incf deleted)))) (cj/quick-capture)) (should (= deleted 0)))) -;;; cj/--org-capture-popup-strip-specials (drop the Customize menu entry) - -(ert-deftest test-org-capture-config-popup-strip-specials-removes-customize () - "Normal: the \"C\" Customize entry is removed, \"q\" Abort kept, order intact." - (should (equal (cj/--org-capture-popup-strip-specials - '(("C" "Customize org-capture-templates") ("q" "Abort"))) - '(("q" "Abort"))))) - -(ert-deftest test-org-capture-config-popup-strip-specials-no-customize () - "Boundary: specials without a \"C\" entry pass through unchanged." - (should (equal (cj/--org-capture-popup-strip-specials '(("q" "Abort"))) - '(("q" "Abort"))))) - -(ert-deftest test-org-capture-config-popup-strip-specials-empty () - "Error/Boundary: nil specials yields nil without raising." - (should-not (cj/--org-capture-popup-strip-specials nil))) - ;;; cj/org-capture--popup-frame-p (ert-deftest test-org-capture-config-popup-frame-p () @@ -212,26 +148,6 @@ the finalize hook owns that." (cl-letf (((symbol-function 'frame-parameter) (lambda (&rest _) "emacs"))) (should-not (cj/org-capture--popup-frame-p)))) -;;; cj/org-capture--popup-mks-advice (frame-gated specials stripping) - -(ert-deftest test-org-capture-config-popup-mks-advice-strips-in-popup () - "Integration: in the popup frame, org-mks receives specials without \"C\"." - (let (seen) - (cl-letf (((symbol-function 'cj/org-capture--popup-frame-p) (lambda () t))) - (cj/org-capture--popup-mks-advice - (lambda (_table _title _prompt specials) (setq seen specials)) - nil nil nil '(("C" "Customize org-capture-templates") ("q" "Abort")))) - (should (equal seen '(("q" "Abort")))))) - -(ert-deftest test-org-capture-config-popup-mks-advice-keeps-elsewhere () - "Integration: in a normal frame, org-mks receives the specials untouched." - (let (seen) - (cl-letf (((symbol-function 'cj/org-capture--popup-frame-p) (lambda () nil))) - (cj/org-capture--popup-mks-advice - (lambda (_table _title _prompt specials) (setq seen specials)) - nil nil nil '(("C" "Customize org-capture-templates") ("q" "Abort")))) - (should (equal seen '(("C" "Customize org-capture-templates") ("q" "Abort")))))) - ;;; cj/org-capture--popup-frame (find the popup frame by name) (ert-deftest test-org-capture-config-popup-frame-found () @@ -254,8 +170,7 @@ the finalize hook owns that." (ert-deftest test-integration-org-capture-quick-capture-selects-named-frame () "Integration: cj/quick-capture selects the \"org-capture\" frame found by name, not whatever frame happens to be selected (the emacsclient -c focus race)." - (let ((org-capture-templates test-org-capture-popup--sample-templates) - (focused nil)) + (let ((focused nil)) (cl-letf (((symbol-function 'cj/org-capture--popup-frame) (lambda () 'popup-frame)) ((symbol-function 'select-frame-set-input-focus) (lambda (f) (setq focused f))) @@ -266,8 +181,7 @@ not whatever frame happens to be selected (the emacsclient -c focus race)." (ert-deftest test-integration-org-capture-quick-capture-no-frame-still-captures () "Integration: when no popup frame is found, cj/quick-capture skips the focus call and still runs the capture (no error)." - (let ((org-capture-templates test-org-capture-popup--sample-templates) - (focused 'unset) + (let ((focused 'unset) (captured nil)) (cl-letf (((symbol-function 'cj/org-capture--popup-frame) (lambda () nil)) ((symbol-function 'select-frame-set-input-focus) diff --git a/tests/test-org-config-table-header.el b/tests/test-org-config-table-header.el new file mode 100644 index 000000000..38e73b483 --- /dev/null +++ b/tests/test-org-config-table-header.el @@ -0,0 +1,115 @@ +;;; test-org-config-table-header.el --- In-buffer org table header fontify -*- lexical-binding: t; -*- + +;;; Commentary: +;; Org has no in-buffer header-row face -- the whole table uses `org-table'. +;; cj/--org-table-header-row-p, cj/--org-table-first-hline-position, and the +;; font-lock matcher cj/--org-fontify-table-header-matcher (org-config.el) add +;; one: they identify a table's header rows (the non-hline rows above its first +;; hline) so font-lock can prepend `org-table-header' there. These exercise the +;; detection logic directly against fixture tables, matching the tag-alignment +;; test's pure-logic style. + +;;; Code: + +(require 'ert) +(require 'org) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-config) + +(defmacro test-org-th--in (content &rest body) + "Run BODY in a temp org buffer holding CONTENT, hooks suppressed." + (declare (indent 1)) + `(let ((org-mode-hook nil)) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +(defun test-org-th--goto (substring) + "Move point to the beginning of the line containing SUBSTRING." + (goto-char (point-min)) + (search-forward substring) + (beginning-of-line)) + +;; ----- cj/--org-table-header-row-p ----- + +(ert-deftest test-org-table-header-row-p-header-above-hline () + "Normal: a non-hline row above the first hline is a header row." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "Name") + (should (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-body-row-not-header () + "Normal: a row below the first hline is not a header row." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "Bob") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-hline-not-header () + "Boundary: the hline itself is not a header row." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "----") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-no-hline-no-header () + "Boundary: a table with no hline has no header rows." + (test-org-th--in "| A | B |\n| x | y |\n" + (test-org-th--goto "A |") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-multi-row-header () + "Boundary: every non-hline row above the first hline is a header row." + (test-org-th--in "| A | B |\n| C | D |\n|---+---|\n| x | y |\n" + (test-org-th--goto "A |") + (should (cj/--org-table-header-row-p)) + (test-org-th--goto "C |") + (should (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-key-value-first-row-only () + "Boundary: hline-after-every-row table -- only the first row is header." + (test-org-th--in "| Status | draft |\n|--------+-------|\n| Owner | cj |\n|--------+-------|\n" + (test-org-th--goto "Status") + (should (cj/--org-table-header-row-p)) + (test-org-th--goto "Owner") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-non-table-line () + "Error: a line that is not in a table is never a header row." + (test-org-th--in "Just some prose.\n" + (test-org-th--goto "prose") + (should-not (cj/--org-table-header-row-p)))) + +;; ----- cj/--org-table-first-hline-position ----- + +(ert-deftest test-org-table-first-hline-position-found () + "Normal: returns the bol of the first hline in the table." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "Name") + (let ((expected (save-excursion (goto-char (point-min)) + (forward-line 1) + (line-beginning-position)))) + (should (equal (cj/--org-table-first-hline-position) expected))))) + +(ert-deftest test-org-table-first-hline-position-none () + "Boundary: a table with no hline returns nil." + (test-org-th--in "| A | B |\n| x | y |\n" + (test-org-th--goto "A |") + (should-not (cj/--org-table-first-hline-position)))) + +;; ----- cj/--org-fontify-table-header-matcher ----- + +(ert-deftest test-org-fontify-table-header-matcher-matches-header-only () + "Normal: the matcher sets match data to the header row, then stops." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (should (cj/--org-fontify-table-header-matcher (point-max))) + (should (equal (match-string 0) "| Name | Age |")) + (should-not (cj/--org-fontify-table-header-matcher (point-max))))) + +(ert-deftest test-org-fontify-table-header-matcher-no-header () + "Boundary: a table with no hline yields no matches." + (test-org-th--in "| A | B |\n| x | y |\n" + (should-not (cj/--org-fontify-table-header-matcher (point-max))))) + +(provide 'test-org-config-table-header) +;;; test-org-config-table-header.el ends here diff --git a/tests/test-org-faces-config.el b/tests/test-org-faces-config.el new file mode 100644 index 000000000..8e7da3309 --- /dev/null +++ b/tests/test-org-faces-config.el @@ -0,0 +1,54 @@ +;;; test-org-faces-config.el --- Tests for org-faces-config -*- lexical-binding: t; -*- + +;;; Commentary: +;; Verifies the custom agenda header-row faces exist and that the keyword and +;; priority maps wire each keyword / priority to its org-faces-* face. org is +;; required first so the `with-eval-after-load' wiring in org-faces-config fires +;; on load. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-faces-config) + +(ert-deftest test-org-faces-config-base-faces-exist () + "Normal: every base keyword and priority face is defined." + (dolist (f '(org-faces-todo org-faces-project org-faces-doing org-faces-waiting + org-faces-verify org-faces-stalled org-faces-delegated org-faces-failed + org-faces-done org-faces-cancelled + org-faces-priority-a org-faces-priority-b org-faces-priority-c org-faces-priority-d)) + (should (facep f)))) + +(ert-deftest test-org-faces-config-dim-faces-exist () + "Normal: every dim variant is defined (auto-dim remaps onto these)." + (dolist (f '(org-faces-todo-dim org-faces-project-dim org-faces-doing-dim org-faces-waiting-dim + org-faces-verify-dim org-faces-stalled-dim org-faces-delegated-dim org-faces-failed-dim + org-faces-done-dim org-faces-cancelled-dim + org-faces-priority-a-dim org-faces-priority-b-dim org-faces-priority-c-dim org-faces-priority-d-dim)) + (should (facep f)))) + +(ert-deftest test-org-faces-config-keyword-map () + "Normal: representative keywords map to their org-faces-* face." + (should (eq (cdr (assoc "TODO" org-todo-keyword-faces)) 'org-faces-todo)) + (should (eq (cdr (assoc "VERIFY" org-todo-keyword-faces)) 'org-faces-verify)) + (should (eq (cdr (assoc "CANCELLED" org-todo-keyword-faces)) 'org-faces-cancelled)) + (should (eq (cdr (assoc "DELEGATED" org-todo-keyword-faces)) 'org-faces-delegated))) + +(ert-deftest test-org-faces-config-keyword-coverage () + "Boundary: all ten keywords are mapped, each to a real face." + (dolist (kw '("TODO" "PROJECT" "DOING" "WAITING" "VERIFY" "STALLED" + "DELEGATED" "FAILED" "DONE" "CANCELLED")) + (let ((face (cdr (assoc kw org-todo-keyword-faces)))) + (should face) + (should (facep face))))) + +(ert-deftest test-org-faces-config-priority-map () + "Normal: each priority A-D maps to its org-faces-priority-* face." + (should (eq (cdr (assq ?A org-priority-faces)) 'org-faces-priority-a)) + (should (eq (cdr (assq ?B org-priority-faces)) 'org-faces-priority-b)) + (should (eq (cdr (assq ?C org-priority-faces)) 'org-faces-priority-c)) + (should (eq (cdr (assq ?D org-priority-faces)) 'org-faces-priority-d))) + +(provide 'test-org-faces-config) +;;; test-org-faces-config.el ends here diff --git a/tests/test-prog-c-mode-settings.el b/tests/test-prog-c-mode-settings.el index eef2d9102..37a77a213 100644 --- a/tests/test-prog-c-mode-settings.el +++ b/tests/test-prog-c-mode-settings.el @@ -16,7 +16,7 @@ "Normal: cj/c-mode-settings applies the documented buffer-local values." (with-temp-buffer (cl-letf (((symbol-function 'auto-fill-mode) (lambda (&rest _) nil)) - ((symbol-function 'electric-pair-mode) (lambda (&rest _) nil)) + ((symbol-function 'electric-pair-local-mode) (lambda (&rest _) nil)) ((symbol-function 'lsp-deferred) (lambda (&rest _) nil)) ((symbol-function 'executable-find) (lambda (_) nil))) (cj/c-mode-settings)) @@ -31,7 +31,7 @@ (let ((lsp-calls 0)) (with-temp-buffer (cl-letf (((symbol-function 'auto-fill-mode) (lambda (&rest _) nil)) - ((symbol-function 'electric-pair-mode) (lambda (&rest _) nil)) + ((symbol-function 'electric-pair-local-mode) (lambda (&rest _) nil)) ((symbol-function 'lsp-deferred) (lambda () (cl-incf lsp-calls))) ((symbol-function 'executable-find) (lambda (_) "/usr/bin/clangd"))) (cj/c-mode-settings))) @@ -42,7 +42,7 @@ (let ((lsp-calls 0)) (with-temp-buffer (cl-letf (((symbol-function 'auto-fill-mode) (lambda (&rest _) nil)) - ((symbol-function 'electric-pair-mode) (lambda (&rest _) nil)) + ((symbol-function 'electric-pair-local-mode) (lambda (&rest _) nil)) ((symbol-function 'lsp-deferred) (lambda () (cl-incf lsp-calls))) ((symbol-function 'executable-find) (lambda (_) nil))) (cj/c-mode-settings))) diff --git a/tests/test-prog-general--deadgrep.el b/tests/test-prog-general--deadgrep.el new file mode 100644 index 000000000..21223105d --- /dev/null +++ b/tests/test-prog-general--deadgrep.el @@ -0,0 +1,44 @@ +;;; test-prog-general--deadgrep.el --- Tests for the deadgrep helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/deadgrep--initial-term (region text or symbol at point) and cj/--deadgrep-run +;; (the normalize-root + read-term + invoke tail shared by cj/deadgrep-here and +;; cj/deadgrep-in-dir) were lifted out of the deadgrep use-package :config. +;; deadgrep is mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +(ert-deftest test-prg-deadgrep-initial-term-symbol-at-point () + "Normal: with no region, the symbol at point seeds the search." + (with-temp-buffer + (insert "hello world") + (goto-char (point-min)) + (should (equal (cj/deadgrep--initial-term) "hello")))) + +(ert-deftest test-prg-deadgrep-initial-term-region () + "Normal: an active region's text seeds the search." + (with-temp-buffer + (insert "needle") + (transient-mark-mode 1) + (set-mark (point-min)) + (goto-char (point-max)) + (activate-mark) + (should (equal (cj/deadgrep--initial-term) "needle")))) + +(ert-deftest test-prg-deadgrep-run-normalizes-root-and-passes-term () + "Normal: ROOT is normalized to a directory and TERM is passed through." + (let (got-term got-root) + (cl-letf (((symbol-function 'deadgrep) + (lambda (term root) (setq got-term term got-root root)))) + (cj/--deadgrep-run "/tmp/foo" "needle")) + (should (equal got-term "needle")) + (should (equal got-root "/tmp/foo/")))) + +(provide 'test-prog-general--deadgrep) +;;; test-prog-general--deadgrep.el ends here diff --git a/tests/test-prog-general--find-project-root-file.el b/tests/test-prog-general--find-project-root-file.el new file mode 100644 index 000000000..97db0b979 --- /dev/null +++ b/tests/test-prog-general--find-project-root-file.el @@ -0,0 +1,49 @@ +;;; test-prog-general--find-project-root-file.el --- Tests for cj/find-project-root-file -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/find-project-root-file returns the first file in the current Projectile +;; project root matching a regexp (string or rx form), case-insensitively. It +;; was defined inside the projectile use-package :config (unreachable under +;; `make test'); lifting it to top level makes it unit-testable. projectile's +;; root and directory-files are mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'seq) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +(defmacro test-prg--with-root (files &rest body) + "Run BODY with projectile-project-root \"/proj/\" and directory-files = FILES." + (declare (indent 1)) + `(cl-letf (((symbol-function 'projectile-project-root) (lambda (&rest _) "/proj/")) + ((symbol-function 'directory-files) (lambda (&rest _) ,files))) + ,@body)) + +(ert-deftest test-prg-find-root-file-string-regexp () + "Normal: a string regexp matches case-insensitively." + (test-prg--with-root '("README.md" "TODO.org" "src") + (should (equal (cj/find-project-root-file "^todo\\.org$") "TODO.org")))) + +(ert-deftest test-prg-find-root-file-rx-form () + "Normal: an rx form is converted and matched." + (test-prg--with-root '("notes.txt" "todo.md" "x") + (should (equal (cj/find-project-root-file + '(seq bos "todo." (or "org" "md" "txt") eos)) + "todo.md")))) + +(ert-deftest test-prg-find-root-file-no-match () + "Boundary: no matching file yields nil." + (test-prg--with-root '("a.el" "b.el") + (should (null (cj/find-project-root-file "^todo\\.org$"))))) + +(ert-deftest test-prg-find-root-file-no-project () + "Boundary: outside a project (nil root) yields nil." + (cl-letf (((symbol-function 'projectile-project-root) (lambda (&rest _) nil))) + (should (null (cj/find-project-root-file "^todo\\.org$"))))) + +(provide 'test-prog-general--find-project-root-file) +;;; test-prog-general--find-project-root-file.el ends here diff --git a/tests/test-prog-go-commands.el b/tests/test-prog-go-commands.el index 6947f358b..a2fc0625f 100644 --- a/tests/test-prog-go-commands.el +++ b/tests/test-prog-go-commands.el @@ -27,19 +27,19 @@ "Normal: tab-width 4, standard-indent 4, indent-tabs-mode t (Go convention)." (with-temp-buffer (cl-letf (((symbol-function 'company-mode) #'ignore) - ((symbol-function 'electric-pair-mode) #'ignore)) + ((symbol-function 'electric-pair-local-mode) #'ignore)) (cj/go-setup) (should (= tab-width 4)) (should (= standard-indent 4)) (should indent-tabs-mode)))) (ert-deftest test-prog-go-setup-enables-mode-helpers () - "Normal: company-mode and electric-pair-mode are both called." + "Normal: company-mode and electric-pair-local-mode are both called." (with-temp-buffer (let ((called nil)) (cl-letf (((symbol-function 'company-mode) (lambda (&rest _) (push 'company called))) - ((symbol-function 'electric-pair-mode) + ((symbol-function 'electric-pair-local-mode) (lambda (arg) (push (cons 'pair arg) called)))) (cj/go-setup)) (should (memq 'company called)) @@ -50,7 +50,7 @@ (with-temp-buffer (let ((started nil)) (cl-letf (((symbol-function 'company-mode) #'ignore) - ((symbol-function 'electric-pair-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) @@ -63,7 +63,7 @@ (with-temp-buffer (let ((started nil)) (cl-letf (((symbol-function 'company-mode) #'ignore) - ((symbol-function 'electric-pair-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) (lambda (_) nil))) diff --git a/tests/test-reconcile--dirty-p.el b/tests/test-reconcile--dirty-p.el new file mode 100644 index 000000000..a4c372b66 --- /dev/null +++ b/tests/test-reconcile--dirty-p.el @@ -0,0 +1,49 @@ +;;; test-reconcile--dirty-p.el --- Tests for cj/reconcile--dirty-p -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `cj/reconcile--dirty-p' in reconcile-open-repos.el. It runs +;; git status --porcelain via `cj/reconcile--git' and reports clean (nil), +;; dirty (non-nil), or 'status-failed when git itself errors. The git call +;; is stubbed at the `cj/reconcile--git' boundary (it returns a plist). + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'reconcile-open-repos) + +(defmacro test-reconcile-dirty--with-git (plist &rest body) + "Run BODY with `cj/reconcile--git' stubbed to return PLIST." + (declare (indent 1)) + `(cl-letf (((symbol-function 'cj/reconcile--git) + (lambda (&rest _) ,plist))) + ,@body)) + +;;; Normal Cases + +(ert-deftest test-reconcile-dirty-p-clean-returns-nil () + "Normal: exit 0 with empty porcelain output means clean (nil)." + (test-reconcile-dirty--with-git '(:exit 0 :output "") + (should-not (cj/reconcile--dirty-p "/repo")))) + +(ert-deftest test-reconcile-dirty-p-dirty-returns-non-nil () + "Normal: exit 0 with porcelain content means dirty (non-nil)." + (test-reconcile-dirty--with-git '(:exit 0 :output " M file.el\n") + (should (cj/reconcile--dirty-p "/repo")))) + +;;; Boundary Cases + +(ert-deftest test-reconcile-dirty-p-whitespace-only-is-clean () + "Boundary: whitespace-only output trims to empty and counts as clean." + (test-reconcile-dirty--with-git '(:exit 0 :output " \n") + (should-not (cj/reconcile--dirty-p "/repo")))) + +;;; Error Cases + +(ert-deftest test-reconcile-dirty-p-git-failure-returns-status-failed () + "Error: a non-zero git exit returns the symbol 'status-failed." + (test-reconcile-dirty--with-git '(:exit 128 :output "fatal: not a repo") + (should (eq (cj/reconcile--dirty-p "/repo") 'status-failed)))) + +(provide 'test-reconcile--dirty-p) +;;; test-reconcile--dirty-p.el ends here diff --git a/tests/test-reconcile--find-git-repos.el b/tests/test-reconcile--find-git-repos.el index e065fca90..c6a190a17 100644 --- a/tests/test-reconcile--find-git-repos.el +++ b/tests/test-reconcile--find-git-repos.el @@ -81,6 +81,15 @@ (should (= (length repos) 1)) (should (string-suffix-p "visible-repo" (car repos)))))) +(ert-deftest test-find-git-repos-boundary-dotted-repo-name-found () + "Boundary: a repo whose directory name contains a dot (e.g. mcp.el) is +discovered. Regression for the `^[^.]+$' filter that matched only dot-free +names and silently skipped dotted repos like mcp.el / capture.el." + (reconcile-test-with-temp-dirs + ("mcp.el/.git/" "capture.el/.git/" "plain-repo/.git/") + (let ((repos (cj/find-git-repos test-root))) + (should (= (length repos) 3))))) + (ert-deftest test-find-git-repos-boundary-prunes-heavy-directories () "Skips generated/heavy directories while discovering repos." (reconcile-test-with-temp-dirs diff --git a/tests/test-selection-framework--consult-line-or-repeat.el b/tests/test-selection-framework--consult-line-or-repeat.el index fcaddcfd0..66f5b1724 100644 --- a/tests/test-selection-framework--consult-line-or-repeat.el +++ b/tests/test-selection-framework--consult-line-or-repeat.el @@ -64,5 +64,11 @@ "Normal: `cj/consult-line-or-repeat' is an interactive command." (should (commandp #'cj/consult-line-or-repeat))) +(ert-deftest test-selection-framework-vertico-repeat-save-on-minibuffer-setup () + "Normal: loading the module registers `vertico-repeat-save' on +`minibuffer-setup-hook'. Without it `vertico-repeat' has no saved session +and the second C-s signals \"No Vertico session\"." + (should (memq 'vertico-repeat-save minibuffer-setup-hook))) + (provide 'test-selection-framework--consult-line-or-repeat) ;;; test-selection-framework--consult-line-or-repeat.el ends here diff --git a/tests/test-show-kill-ring--insert-item.el b/tests/test-show-kill-ring--insert-item.el new file mode 100644 index 000000000..a29ca75e6 --- /dev/null +++ b/tests/test-show-kill-ring--insert-item.el @@ -0,0 +1,73 @@ +;;; test-show-kill-ring--insert-item.el --- Tests for show-kill-insert-item -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `show-kill-insert-item' in show-kill-ring.el — inserts a +;; kill-ring entry into the current buffer, truncating to +;; `show-kill-max-item-size' with an ellipsis when too long. The ellipsis +;; sits inline for short items and on its own line for items wider than the +;; frame. Frame width is read at runtime so the test is environment-stable. + +;;; Code: + +(require 'ert) +(require 'show-kill-ring) + +;;; Normal Cases + +(ert-deftest test-show-kill-ring-insert-item-short-verbatim () + "Normal: an item shorter than the max is inserted unchanged." + (let ((show-kill-max-item-size 1000)) + (with-temp-buffer + (show-kill-insert-item "hello") + (should (string= (buffer-string) "hello"))))) + +(ert-deftest test-show-kill-ring-insert-item-inline-ellipsis () + "Normal: an over-max item narrower than the frame gets an inline ellipsis." + (let* ((show-kill-max-item-size 5) + (len (/ (frame-width) 2)) ; > max, < (frame-width - 5) + (item (make-string len ?b))) + (with-temp-buffer + (show-kill-insert-item item) + (should (string= (buffer-string) "bbbbb..."))))) + +;;; Boundary Cases + +(ert-deftest test-show-kill-ring-insert-item-length-equals-max-truncates () + "Boundary: length exactly equal to max truncates — the guard is (< len max)." + (let ((show-kill-max-item-size 5)) + (with-temp-buffer + (show-kill-insert-item "hello") ; length 5, equals max + (should (string= (buffer-string) "hello..."))))) + +(ert-deftest test-show-kill-ring-insert-item-wide-newline-ellipsis () + "Boundary: an item wider than the frame puts the ellipsis on its own line." + (let* ((show-kill-max-item-size 5) + (item (make-string (+ (frame-width) 10) ?a))) + (with-temp-buffer + (show-kill-insert-item item) + (should (string= (buffer-string) "aaaaa\n..."))))) + +(ert-deftest test-show-kill-ring-insert-item-max-nil-verbatim () + "Boundary: a non-numeric max disables truncation." + (let ((show-kill-max-item-size nil)) + (with-temp-buffer + (show-kill-insert-item "anything long enough to exceed nothing") + (should (string= (buffer-string) + "anything long enough to exceed nothing"))))) + +(ert-deftest test-show-kill-ring-insert-item-max-negative-verbatim () + "Boundary: a negative max disables truncation." + (let ((show-kill-max-item-size -1)) + (with-temp-buffer + (show-kill-insert-item "abc") + (should (string= (buffer-string) "abc"))))) + +(ert-deftest test-show-kill-ring-insert-item-empty-string () + "Boundary: an empty item inserts nothing and does not error." + (let ((show-kill-max-item-size 1000)) + (with-temp-buffer + (show-kill-insert-item "") + (should (string= (buffer-string) ""))))) + +(provide 'test-show-kill-ring--insert-item) +;;; test-show-kill-ring--insert-item.el ends here diff --git a/tests/test-signal-config-notify.el b/tests/test-signal-config-notify.el index c4067a663..1a7722893 100644 --- a/tests/test-signal-config-notify.el +++ b/tests/test-signal-config-notify.el @@ -6,7 +6,7 @@ ;; `cj/signal--notify-body-max') and `cj/signel--notify' routing (the ;; suppression gate, the notify-script path with the sound flag, and ;; the `notifications-notify' fallback). Spec: the "Notification -;; slice" addendum in docs/design/signal-client.org. No signal-cli or +;; slice" addendum in docs/specs/signal-client-spec-doing.org. No signal-cli or ;; linked account needed. ;;; Code: diff --git a/tests/test-signel-notify-function.el b/tests/test-signel-notify-function.el index cff7f7394..e3d97af51 100644 --- a/tests/test-signel-notify-function.el +++ b/tests/test-signel-notify-function.el @@ -3,7 +3,7 @@ ;;; Commentary: ;; signel's receive handler (signel.el in the fork at ~/code/signel) ;; raised notifications through a hardwired `notifications-notify' -;; call. The notification slice (docs/design/signal-client.org, +;; call. The notification slice (docs/specs/signal-client-spec-doing.org, ;; "Notification slice" addendum) replaces that with ;; `signel-notify-function', a customization point called with ;; CHAT-ID, SENDER, and BODY so a config layer can add suppression or diff --git a/tests/test-slack-config-close-all.el b/tests/test-slack-config-close-all.el new file mode 100644 index 000000000..a7f5423b8 --- /dev/null +++ b/tests/test-slack-config-close-all.el @@ -0,0 +1,32 @@ +;;; test-slack-config-close-all.el --- cj/slack-close-all-buffers guard -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/slack-close-all-buffers iterates every buffer. It must not signal +;; void-variable when `slack-current-buffer' has no binding in a buffer (slack +;; not loaded), and must kill only buffers where it is set non-nil. The original +;; read it with `buffer-local-value' (which errors on buffers without the local +;; binding) instead of guarding like its sibling cj/slack-mark-read-and-bury. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'slack-config) + +(ert-deftest test-slack-close-all-buffers-skips-unbound-kills-slack () + "Error/Normal: no signal on buffers without `slack-current-buffer'; only +buffers that have it set non-nil are killed." + (let ((plain (generate-new-buffer " *plain*")) + (slackish (generate-new-buffer " *slackish*"))) + (with-current-buffer slackish (setq-local slack-current-buffer t)) + (unwind-protect + (progn + (cj/slack-close-all-buffers) + (should (buffer-live-p plain)) + (should-not (buffer-live-p slackish))) + (when (buffer-live-p plain) (kill-buffer plain)) + (when (buffer-live-p slackish) (kill-buffer slackish))))) + +(provide 'test-slack-config-close-all) +;;; test-slack-config-close-all.el ends here diff --git a/tests/test-system-defaults.el b/tests/test-system-defaults.el index 3c5e59777..928124f56 100644 --- a/tests/test-system-defaults.el +++ b/tests/test-system-defaults.el @@ -24,7 +24,10 @@ "Normal: custom-file points at a throwaway temp file, never the repo. This is what stops accidental Customize writes from landing in tracked init." (test-system-defaults--with-load-environment - (let ((custom-file nil)) + ;; noninteractive is t under ERT batch; bind it nil so the interactive + ;; redirect runs (the module guards the redirect to interactive sessions). + (let ((custom-file nil) + (noninteractive nil)) (test-system-defaults--load) (should (stringp custom-file)) (should (string-prefix-p (file-name-as-directory @@ -35,6 +38,15 @@ This is what stops accidental Customize writes from landing in tracked init." (should-not (string-prefix-p (expand-file-name user-emacs-directory) (expand-file-name custom-file)))))) +(ert-deftest test-system-defaults-custom-file-not-littered-in-batch () + "Boundary: a noninteractive (batch) load does not create a trashbin custom-file. +Guards make validate-modules / byte-compile from dropping a temp file per run." + (test-system-defaults--with-load-environment + (let ((custom-file nil) + (noninteractive t)) + (test-system-defaults--load) + (should-not custom-file)))) + ;;; backup directory (ert-deftest test-system-defaults-backups-redirected-under-user-emacs-dir () diff --git a/tests/test-system-lib--format-region-with-program.el b/tests/test-system-lib--format-region-with-program.el new file mode 100644 index 000000000..29b392b84 --- /dev/null +++ b/tests/test-system-lib--format-region-with-program.el @@ -0,0 +1,68 @@ +;;; test-system-lib--format-region-with-program.el --- Tests for cj/format-region-with-program -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/format-region-with-program' runs an external formatter over the whole +;; buffer via `call-process-region' (argv, no shell) and replaces the buffer +;; only when the program exits zero. Extracted from the byte-identical +;; per-language helpers in prog-json.el / prog-yaml.el, so this is the first +;; direct unit coverage of the logic. call-process-region is mocked at the +;; boundary (the established pattern in test-prog-json--json-format-buffer.el). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'system-lib) + +(ert-deftest test-system-lib-format-region-with-program-replaces-on-success () + "Normal: on exit 0 the buffer is replaced with the program's output, returns t." + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end _prog &rest rest) + (with-current-buffer (nth 1 rest) (insert "FORMATTED")) + 0))) + (with-temp-buffer + (insert "raw") + (should (eq t (cj/format-region-with-program "fmt"))) + (should (equal "FORMATTED" (buffer-string)))))) + +(ert-deftest test-system-lib-format-region-with-program-forwards-argv () + "Normal: PROGRAM and ARGS reach call-process-region as argv (no shell)." + (let (got-prog got-args) + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end prog &rest rest) + (setq got-prog prog + got-args (nthcdr 3 rest)) + (with-current-buffer (nth 1 rest) (insert "x")) + 0))) + (with-temp-buffer + (cj/format-region-with-program "jq" "--sort-keys" "."))) + (should (equal "jq" got-prog)) + (should (equal '("--sort-keys" ".") got-args)))) + +(ert-deftest test-system-lib-format-region-with-program-empty-output () + "Boundary: empty program output empties the buffer and still returns t." + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end _prog &rest _rest) 0))) ; writes nothing + (with-temp-buffer + (insert "raw") + (should (eq t (cj/format-region-with-program "fmt"))) + (should (equal "" (buffer-string)))))) + +(ert-deftest test-system-lib-format-region-with-program-nonzero-untouched () + "Error: a non-zero exit leaves the buffer untouched and signals user-error +carrying the program's stderr text." + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end _prog &rest rest) + (with-current-buffer (nth 1 rest) (insert "boom: bad input")) + 1))) + (with-temp-buffer + (insert "raw") + (let ((err (should-error (cj/format-region-with-program "fmt") + :type 'user-error))) + (should (string-match-p "boom: bad input" (error-message-string err)))) + (should (equal "raw" (buffer-string)))))) + +(provide 'test-system-lib--format-region-with-program) +;;; test-system-lib--format-region-with-program.el ends here diff --git a/tests/test-system-lib-confirm-strong.el b/tests/test-system-lib-confirm-strong.el new file mode 100644 index 000000000..26c008228 --- /dev/null +++ b/tests/test-system-lib-confirm-strong.el @@ -0,0 +1,37 @@ +;;; test-system-lib-confirm-strong.el --- Tests for cj/confirm-strong -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/confirm-strong', the typed-"yes" confirmation used for +;; irreversible actions. The behavior under test is the long-form guarantee: +;; the prompt demands a typed yes/no even when the global single-key default +;; (`use-short-answers') is in effect. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'system-lib) + +(ert-deftest test-system-lib-confirm-strong-returns-t-on-yes () + "Normal: passes a t answer through from `yes-or-no-p'." + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t))) + (should (eq (cj/confirm-strong "Really? ") t)))) + +(ert-deftest test-system-lib-confirm-strong-returns-nil-on-no () + "Normal: passes a nil answer through from `yes-or-no-p'." + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) nil))) + (should (eq (cj/confirm-strong "Really? ") nil)))) + +(ert-deftest test-system-lib-confirm-strong-forces-long-form () + "Boundary: binds `use-short-answers' to nil for the call even when it is +globally t, so the irreversible prompt requires a typed yes/no regardless of +the single-key default." + (let ((use-short-answers t) + (seen 'unset)) + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (&rest _) (setq seen use-short-answers) t))) + (cj/confirm-strong "Really? ") + (should (eq seen nil))))) + +(provide 'test-system-lib-confirm-strong) +;;; test-system-lib-confirm-strong.el ends here diff --git a/tests/test-system-lib-font-lock-global-modes.el b/tests/test-system-lib-font-lock-global-modes.el new file mode 100644 index 000000000..e074bd256 --- /dev/null +++ b/tests/test-system-lib-font-lock-global-modes.el @@ -0,0 +1,46 @@ +;;; test-system-lib-font-lock-global-modes.el --- Tests for the font-lock exclusion helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/--font-lock-global-modes-excluding', the pure transform +;; behind `cj/exclude-from-global-font-lock'. Some major modes (dashboard, +;; mu4e) paint their buffers with manual `face' text properties; global +;; font-lock then strips those. The helper adds a mode to the +;; `font-lock-global-modes' exclusion, handling its three shapes: t (all +;; modes on), a (not M...) exclusion list, and an (M...) inclusion list. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'system-lib) + +(ert-deftest test-system-lib-flgm-from-t-builds-not-list () + "Normal: t (all modes on) becomes a (not MODE) exclusion." + (let ((r (cj/--font-lock-global-modes-excluding t 'dashboard-mode))) + (should (eq (car r) 'not)) + (should (memq 'dashboard-mode (cdr r))))) + +(ert-deftest test-system-lib-flgm-adds-to-existing-not-list () + "Normal: a second mode is added to an existing (not ...) list." + (let ((r (cj/--font-lock-global-modes-excluding '(not dashboard-mode) 'mu4e-headers-mode))) + (should (eq (car r) 'not)) + (should (memq 'dashboard-mode (cdr r))) + (should (memq 'mu4e-headers-mode (cdr r))))) + +(ert-deftest test-system-lib-flgm-idempotent-on-already-excluded () + "Boundary: excluding an already-excluded mode does not duplicate it." + (let ((r (cj/--font-lock-global-modes-excluding '(not a-mode) 'a-mode))) + (should (eq (car r) 'not)) + (should (= 1 (cl-count 'a-mode (cdr r)))))) + +(ert-deftest test-system-lib-flgm-removes-from-inclusion-list () + "Boundary: in an (M...) inclusion list, excluding a mode removes it." + (should (equal (cj/--font-lock-global-modes-excluding '(foo-mode bar-mode) 'foo-mode) + '(bar-mode)))) + +(ert-deftest test-system-lib-flgm-nil-stays-nil () + "Boundary: nil (no mode gets global font-lock) already excludes everything." + (should (equal (cj/--font-lock-global-modes-excluding nil 'x-mode) nil))) + +(provide 'test-system-lib-font-lock-global-modes) +;;; test-system-lib-font-lock-global-modes.el ends here diff --git a/tests/test-term-toggle--display.el b/tests/test-term-toggle--display.el index 0943a4888..d6dd33da2 100644 --- a/tests/test-term-toggle--display.el +++ b/tests/test-term-toggle--display.el @@ -17,7 +17,9 @@ (require 'term-config) (ert-deftest test-term-toggle--capture-state-records-direction-and-size () - "Normal: capture-state writes direction and integer body size." + "Normal: capture-state writes direction and integer size. +The vertical axis captures total-height (not body-height) so the toggle +round-trip is immune to the mode line's pixel height." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below)) @@ -26,7 +28,7 @@ (cj/--term-toggle-capture-state below) (should (eq cj/--term-toggle-last-direction 'below)) (should (integerp cj/--term-toggle-last-size)) - (should (= cj/--term-toggle-last-size (window-body-height below)))))) + (should (= cj/--term-toggle-last-size (window-total-height below)))))) (ert-deftest test-term-toggle--capture-state-noop-on-dead-window () "Boundary: nil window -> state remains unchanged." @@ -50,7 +52,9 @@ (should (eq (cdr (assq 'inhibit-same-window received-alist)) t)))) (ert-deftest test-term-toggle--display-saved-maps-cardinal-to-edge () - "Normal: saved 'below maps to bottom edge; integer size wraps in body-lines." + "Normal: saved 'below maps to bottom edge; integer size is a plain total-line count. +The height axis replays a total-line integer (not a body-lines cons) so the +round-trip is immune to the mode line's pixel height." (let (received-alist (cj/--term-toggle-last-direction 'below) (cj/--term-toggle-last-size 12)) @@ -58,8 +62,7 @@ (lambda (_b a) (setq received-alist a) 'fake-window))) (cj/--term-toggle-display-saved 'fake-buf nil)) (should (eq (cdr (assq 'direction received-alist)) 'bottom)) - (should (equal (cdr (assq 'window-height received-alist)) - '(body-lines . 12))) + (should (equal (cdr (assq 'window-height received-alist)) 12)) (should-not (assq 'window-width received-alist)))) (ert-deftest test-term-toggle--display-saved-strips-conflicting-alist-entries () @@ -83,5 +86,29 @@ received-alist))) (should (null wh-cells))))) +(ert-deftest test-term-toggle--default-size-pairs-width-with-right () + "Normal: the default size for `right' is the width fraction." + (let ((cj/term-toggle-window-width 0.5) + (cj/term-toggle-window-height 0.7)) + (should (= (cj/--term-toggle-default-size 'right) 0.5)))) + +(ert-deftest test-term-toggle--default-size-pairs-height-with-below () + "Normal: the default size for `below' is the height fraction." + (let ((cj/term-toggle-window-width 0.5) + (cj/term-toggle-window-height 0.7)) + (should (= (cj/--term-toggle-default-size 'below) 0.7)))) + +(ert-deftest test-term-toggle--default-direction-delegates-to-dock-rule () + "Normal: default-direction passes the width fraction to the dock rule." + (let ((cj/term-toggle-window-width 0.5) + captured) + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (cols frac &rest _) + (setq captured (list cols frac)) + 'right))) + (should (eq (cj/--term-toggle-default-direction) 'right)) + (should (= (nth 1 captured) 0.5)) + (should (integerp (nth 0 captured)))))) + (provide 'test-term-toggle--display) ;;; test-term-toggle--display.el ends here diff --git a/tests/test-ui-buffer-status-colors.el b/tests/test-ui-buffer-status-colors.el deleted file mode 100644 index bb905ad4d..000000000 --- a/tests/test-ui-buffer-status-colors.el +++ /dev/null @@ -1,221 +0,0 @@ -;;; test-ui-buffer-status-colors.el --- Tests for buffer status colors -*- lexical-binding: t; -*- - -;;; Commentary: -;; Unit tests for buffer status color system. -;; Tests the state detection logic used by both cursor color and modeline. - -;;; Code: - -(require 'ert) -(require 'user-constants) -(require 'ui-config) -(require 'modeline-config) - -;;; Color Constant Tests - -(ert-deftest test-buffer-status-colors-has-all-states () - "Test that all required states are defined in color alist." - (should (alist-get 'read-only cj/buffer-status-colors)) - (should (alist-get 'overwrite cj/buffer-status-colors)) - (should (alist-get 'modified cj/buffer-status-colors)) - (should (alist-get 'unmodified cj/buffer-status-colors))) - -(ert-deftest test-buffer-status-colors-values-are-strings () - "Test that all color values are strings (hex colors)." - (dolist (entry cj/buffer-status-colors) - (should (stringp (cdr entry))) - ;; Check if it looks like a hex color - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" (cdr entry))))) - -;;; Cursor Color State Detection Tests - -(ert-deftest test-cursor-color-state-read-only-buffer () - "Test state detection for read-only buffer." - (with-temp-buffer - (setq buffer-read-only t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'read-only))))) - -(ert-deftest test-cursor-color-state-overwrite-mode () - "Test state detection for overwrite mode." - (with-temp-buffer - (setq buffer-read-only nil) - (overwrite-mode 1) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'overwrite))))) - -(ert-deftest test-cursor-color-state-modified-buffer () - "Test state detection for modified buffer." - (with-temp-buffer - (setq buffer-read-only nil) - (insert "test") - (set-buffer-modified-p t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'modified))))) - -(ert-deftest test-cursor-color-state-unmodified-buffer () - "Test state detection for unmodified buffer." - (with-temp-buffer - (setq buffer-read-only nil) - (set-buffer-modified-p nil) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'unmodified))))) - -(ert-deftest test-cursor-color-state-priority-read-only-over-modified () - "Test that read-only state takes priority over modified state." - (with-temp-buffer - (insert "test") - (set-buffer-modified-p t) - (setq buffer-read-only t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'read-only))))) - -(ert-deftest test-cursor-color-state-priority-overwrite-over-modified () - "Test that overwrite mode takes priority over modified state." - (with-temp-buffer - (insert "test") - (set-buffer-modified-p t) - (overwrite-mode 1) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'overwrite))))) - -;;; Integration Tests - Cursor Color Function - -(ert-deftest test-cursor-color-function-exists () - "Test that cursor color function is defined." - (should (fboundp 'cj/set-cursor-color-according-to-mode))) - -(ert-deftest test-cursor-color-returns-correct-color-for-read-only () - "Test cursor color function returns red for read-only buffer." - (with-temp-buffer - (setq buffer-read-only t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#f06a3f"))))) - -(ert-deftest test-cursor-color-returns-correct-color-for-overwrite () - "Test cursor color function returns gold for overwrite mode." - (with-temp-buffer - (overwrite-mode 1) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#c48702"))))) - -(ert-deftest test-cursor-color-returns-correct-color-for-modified () - "Test cursor color function returns green for modified buffer." - (with-temp-buffer - (insert "test") - (set-buffer-modified-p t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#64aa0f"))))) - -(ert-deftest test-cursor-color-returns-correct-color-for-unmodified () - "Test cursor color function returns white for unmodified buffer." - (with-temp-buffer - (set-buffer-modified-p nil) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#ffffff"))))) - -;;; Modeline Integration Tests - -(ert-deftest test-modeline-buffer-name-variable-exists () - "Test that modeline buffer name variable is defined." - (should (boundp 'cj/modeline-buffer-name))) - -(ert-deftest test-modeline-buffer-name-is-mode-line-construct () - "Test that modeline buffer name is a valid mode-line construct." - (should (listp cj/modeline-buffer-name)) - (should (eq (car cj/modeline-buffer-name) :eval))) - -;;; Edge Cases - -(ert-deftest test-buffer-status-new-buffer-starts-unmodified () - "Test that new buffer starts in unmodified state." - (with-temp-buffer - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'unmodified))))) - -(ert-deftest test-buffer-status-insert-makes-modified () - "Test that inserting text changes state to modified." - (with-temp-buffer - ;; Initially unmodified - (set-buffer-modified-p nil) - (let ((state1 (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state1 'unmodified))) - - ;; Insert text - (insert "test") - (let ((state2 (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state2 'modified))))) - -(ert-deftest test-buffer-status-explicit-unmodify () - "Test that explicitly setting unmodified works." - (with-temp-buffer - (insert "test") - (should (buffer-modified-p)) - - ;; Explicitly set unmodified - (set-buffer-modified-p nil) - (let ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'unmodified))))) - -(provide 'test-ui-buffer-status-colors) -;;; test-ui-buffer-status-colors.el ends here diff --git a/tests/test-ui-config--buffer-cursor-state.el b/tests/test-ui-config--buffer-cursor-state.el deleted file mode 100644 index 852865869..000000000 --- a/tests/test-ui-config--buffer-cursor-state.el +++ /dev/null @@ -1,96 +0,0 @@ -;;; test-ui-config--buffer-cursor-state.el --- Tests for cursor-state classification -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/--buffer-cursor-state' picks the buffer-state symbol that -;; `cj/set-cursor-color-according-to-mode' maps to a cursor color via -;; `cj/buffer-status-colors'. The subtle case: a live ghostel terminal is -;; technically `buffer-read-only' but the user types into it -- keystrokes go -;; to the terminal process -- so it must report a writeable state, not -;; `read-only'. ghostel's `copy' / `emacs' input modes are the exception: -;; there the buffer really is a read-only Emacs buffer the user navigates, so -;; `read-only' (the orange cursor) is correct and kept. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(setq load-prefer-newer t) -(defvar ghostel--input-mode nil) -(require 'ui-config) -(require 'testutil-ghostel-buffers) - -(ert-deftest test-ui-config-buffer-cursor-state-readwrite-unmodified () - "Normal: a clean writeable buffer reports `unmodified'." - (with-temp-buffer - (set-buffer-modified-p nil) - (should (eq (cj/--buffer-cursor-state) 'unmodified)))) - -(ert-deftest test-ui-config-buffer-cursor-state-readwrite-modified () - "Normal: a writeable buffer with unsaved changes reports `modified'." - (with-temp-buffer - (insert "x") - (should (eq (cj/--buffer-cursor-state) 'modified)))) - -(ert-deftest test-ui-config-buffer-cursor-state-read-only () - "Normal: a plain read-only buffer reports `read-only'." - (with-temp-buffer - (setq buffer-read-only t) - (should (eq (cj/--buffer-cursor-state) 'read-only)))) - -(ert-deftest test-ui-config-buffer-cursor-state-overwrite () - "Boundary: `overwrite-mode' wins over the modified/unmodified split." - (with-temp-buffer - (insert "x") - (overwrite-mode 1) - (should (eq (cj/--buffer-cursor-state) 'overwrite)))) - -(ert-deftest test-ui-config-buffer-cursor-state-live-ghostel-is-writeable () - "Boundary: a live ghostel buffer is `buffer-read-only' but reports a -writeable state -- the user types into the terminal process there, so the -read-only (orange) cursor would be misleading." - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-ghostel-cursor-state*"))) - (unwind-protect - (with-current-buffer buf - (setq buffer-read-only t) ; ghostel keeps the buffer read-only - (setq-local ghostel--input-mode 'semi-char) - (should-not (eq (cj/--buffer-cursor-state) 'read-only))) - (when (buffer-live-p buf) (kill-buffer buf))))) - -(ert-deftest test-ui-config-buffer-cursor-state-ghostel-copy-mode-is-read-only () - "Boundary: in ghostel `copy' mode the buffer is a read-only Emacs buffer -the user navigates, so `read-only' (orange) is kept." - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-ghostel-cursor-state-copy*"))) - (unwind-protect - (with-current-buffer buf - (setq buffer-read-only t) - (setq-local ghostel--input-mode 'copy) - (should (eq (cj/--buffer-cursor-state) 'read-only))) - (when (buffer-live-p buf) (kill-buffer buf))))) - -(ert-deftest test-ui-config-set-cursor-color-live-ghostel-not-orange () - "Normal: in a live ghostel terminal the cursor-color hook picks a writeable -color, not the read-only orange -- even though the buffer is read-only. -`display-graphic-p' is stubbed t so the function reaches its work body in -batch mode (the live function no-ops on TTY frames by design)." - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-ghostel-cursor-color*")) - (applied 'unset)) - (unwind-protect - (with-current-buffer buf - (setq buffer-read-only t) - (setq-local ghostel--input-mode 'semi-char) - (let ((cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) - ((symbol-function 'set-cursor-color) - (lambda (c) (setq applied c)))) - (cj/set-cursor-color-according-to-mode))) - (should (stringp applied)) - (should-not (equal applied - (alist-get 'read-only cj/buffer-status-colors)))) - (when (buffer-live-p buf) (kill-buffer buf))))) - -(provide 'test-ui-config--buffer-cursor-state) -;;; test-ui-config--buffer-cursor-state.el ends here diff --git a/tests/test-ui-cursor-color-integration.el b/tests/test-ui-cursor-color-integration.el deleted file mode 100644 index c28bde923..000000000 --- a/tests/test-ui-cursor-color-integration.el +++ /dev/null @@ -1,175 +0,0 @@ -;;; test-ui-cursor-color-integration.el --- Integration tests for cursor color -*- lexical-binding: t; -*- - -;;; Commentary: -;; Integration tests for cursor color hook behavior. -;; Tests that cursor color actually updates when switching buffers, -;; modifying files, etc. - -;;; Code: - -(require 'ert) -(require 'user-constants) - -;; `cj/set-cursor-color-according-to-mode' and the `post-command-hook' -;; install both gate on `display-graphic-p' -- a TTY / batch run is a -;; no-op for cursor coloring by design. These integration tests -;; exercise the work body, so we pretend we're in a graphical session -;; for the whole file. Stubbing the symbol BEFORE loading ui-config -;; matters because the hook install reads `display-graphic-p' at load -;; time. -(advice-add 'display-graphic-p :around - (lambda (orig &rest args) (or (apply orig args) t))) - -(require 'ui-config) - -;;; Hook Integration Tests - -(ert-deftest test-cursor-color-integration-post-command-hook-installed () - "Test that post-command-hook is installed." - (should (member 'cj/set-cursor-color-according-to-mode post-command-hook))) - -(ert-deftest test-cursor-color-integration-function-runs-without-error () - "Test that cursor color function runs without error in various buffers." - (with-temp-buffer - (should-not (condition-case err - (progn - (cj/set-cursor-color-according-to-mode) - nil) - (error err)))) - - (with-temp-buffer - (setq buffer-read-only t) - (should-not (condition-case err - (progn - (cj/set-cursor-color-according-to-mode) - nil) - (error err))))) - -(ert-deftest test-cursor-color-integration-internal-buffers-ignored () - "Test that internal buffers (starting with space) are ignored." - (let ((internal-buf (get-buffer-create " *test-internal*")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (with-current-buffer internal-buf - (cj/set-cursor-color-according-to-mode) - ;; Cursor state should not have been updated - (should-not cj/-cursor-last-buffer)) - (kill-buffer internal-buf)))) - -(ert-deftest test-cursor-color-integration-normal-buffers-processed () - "Test that normal buffers (not starting with space) are processed." - (let ((normal-buf (get-buffer-create "test-normal")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (with-current-buffer normal-buf - (cj/set-cursor-color-according-to-mode) - ;; Cursor state should have been updated - (should (equal cj/-cursor-last-buffer "test-normal"))) - (kill-buffer normal-buf)))) - -(ert-deftest test-cursor-color-integration-cache-prevents-redundant-updates () - "Test that cache prevents redundant cursor color updates." - (let* ((normal-buf (generate-new-buffer "test-cache")) - (call-count 0) - (advice-fn (lambda (&rest _) (setq call-count (1+ call-count))))) - (unwind-protect - (progn - (advice-add 'set-cursor-color :before advice-fn) - (with-current-buffer normal-buf - ;; First call - cache matches, no update - (let ((cj/-cursor-last-color "#ffffff") - (cj/-cursor-last-buffer (buffer-name))) - (cj/set-cursor-color-according-to-mode) - (should (= call-count 0))) ; Cached, no update needed - - ;; Modify buffer and clear cache - should update - (insert "test") - (let ((cj/-cursor-last-buffer nil)) ; Force update - (cj/set-cursor-color-according-to-mode) - (should (= call-count 1))))) ; New state, should update - (advice-remove 'set-cursor-color advice-fn) - (kill-buffer normal-buf)))) - -(ert-deftest test-cursor-color-integration-different-buffers-different-colors () - "Test that switching between buffers with different states updates cursor." - (let ((buf1 (generate-new-buffer "test1")) - (buf2 (generate-new-buffer "test2")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (progn - ;; Set buf1 to read-only - (with-current-buffer buf1 - (setq buffer-read-only t) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#f06a3f"))) ; Red - - ;; Set buf2 to normal - (with-current-buffer buf2 - (setq buffer-read-only nil) - (set-buffer-modified-p nil) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#ffffff")))) ; White - (kill-buffer buf1) - (kill-buffer buf2)))) - -(ert-deftest test-cursor-color-integration-buffer-modification-changes-color () - "Test that modifying a buffer changes cursor from white to green." - (let ((normal-buf (generate-new-buffer "test-mod")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (with-current-buffer normal-buf - ;; Start unmodified - (set-buffer-modified-p nil) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#ffffff")) ; White - - ;; Modify buffer - (insert "test") - (should (buffer-modified-p)) - ;; Reset last buffer to force update - (setq cj/-cursor-last-buffer nil) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#64aa0f"))) ; Green - (kill-buffer normal-buf)))) - -(ert-deftest test-cursor-color-integration-save-changes-color-back () - "Test that saving a modified buffer changes cursor from green to white." - (let ((test-file (make-temp-file "test-cursor-")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (progn - ;; Create and modify file - (with-current-buffer (find-file-noselect test-file) - (insert "test") - (should (buffer-modified-p)) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#64aa0f")) ; Green - - ;; Save file - (save-buffer) - (should-not (buffer-modified-p)) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#ffffff")) ; White - (kill-buffer))) - (delete-file test-file)))) - -;;; Performance Tests - -(ert-deftest test-cursor-color-integration-multiple-calls-efficient () - "Test that multiple rapid calls don't cause performance issues." - (with-temp-buffer - (let ((start-time (current-time))) - ;; Call 1000 times - (dotimes (_ 1000) - (cj/set-cursor-color-according-to-mode)) - (let ((elapsed (float-time (time-subtract (current-time) start-time)))) - ;; Should complete in less than 1 second (cache makes this very fast) - (should (< elapsed 1.0)))))) - -(provide 'test-ui-cursor-color-integration) -;;; test-ui-cursor-color-integration.el ends here diff --git a/tests/test-ui-navigation--split-dashboard.el b/tests/test-ui-navigation--split-dashboard.el new file mode 100644 index 000000000..407335f80 --- /dev/null +++ b/tests/test-ui-navigation--split-dashboard.el @@ -0,0 +1,90 @@ +;;; test-ui-navigation--split-dashboard.el --- Tests for split-with-dashboard -*- lexical-binding: t; -*- + +;;; Commentary: +;; C-x 2 / C-x 3 split and show the *dashboard* in the new window while point +;; stays in the original. cj/--split-show-buffer does the placement; +;; cj/split-below/right-with-dashboard wire it to the two split directions. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ui-navigation) + +(ert-deftest test-ui-navigation-split-dashboard-keybindings () + "Normal: C-x 2 / C-x 3 are bound to the dashboard-split commands." + (should (eq (key-binding (kbd "C-x 2")) #'cj/split-below-with-dashboard)) + (should (eq (key-binding (kbd "C-x 3")) #'cj/split-right-with-dashboard))) + +(ert-deftest test-ui-navigation-split-show-buffer-displays-and-keeps-point () + "Normal: the new window shows the buffer; the original stays selected." + (let ((buf (get-buffer-create " *split-dash-test*")) + (config (current-window-configuration))) + (unwind-protect + (progn + (delete-other-windows) + (let* ((orig (selected-window)) + (new (cj/--split-show-buffer #'split-window-below buf))) + (should (window-live-p new)) + (should (not (eq new orig))) + (should (eq (window-buffer new) buf)) + (should (eq (selected-window) orig)))) ; point stays put + (set-window-configuration config) + (kill-buffer buf)))) + +(ert-deftest test-ui-navigation-split-below-routes-to-split-window-below () + "Normal: cj/split-below-with-dashboard splits below with the dashboard buffer." + (let (captured) + (cl-letf (((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard)) + ((symbol-function 'cj/--split-show-buffer) + (lambda (fn buf) (setq captured (list fn buf)) nil))) + (cj/split-below-with-dashboard)) + (should (eq (car captured) #'split-window-below)) + (should (eq (cadr captured) 'dashboard)))) + +(ert-deftest test-ui-navigation-split-right-routes-to-split-window-right () + "Normal: cj/split-right-with-dashboard splits right with the dashboard buffer." + (let (captured) + (cl-letf (((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard)) + ((symbol-function 'cj/--split-show-buffer) + (lambda (fn buf) (setq captured (list fn buf)) nil))) + (cj/split-right-with-dashboard)) + (should (eq (car captured) #'split-window-right)) + (should (eq (cadr captured) 'dashboard)))) + +(ert-deftest test-ui-navigation-split-from-dashboard-p () + "Normal/Boundary: only the dashboard buffer routes the companion to *scratch*." + (should (cj/--split-from-dashboard-p "*dashboard*")) + (should-not (cj/--split-from-dashboard-p "todo.org")) + (should-not (cj/--split-from-dashboard-p "*scratch*"))) + +(ert-deftest test-ui-navigation-split-companion-scratch-from-dashboard () + "Normal: splitting from the dashboard yields the *scratch* buffer, not the +dashboard again." + (cl-letf (((symbol-function 'cj/--split-from-dashboard-p) (lambda (_) t)) + ((symbol-function 'get-scratch-buffer-create) (lambda () 'scratch)) + ((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard))) + (should (eq (cj/--split-companion-buffer) 'scratch)))) + +(ert-deftest test-ui-navigation-split-companion-dashboard-otherwise () + "Normal: splitting from any other buffer yields the dashboard." + (cl-letf (((symbol-function 'cj/--split-from-dashboard-p) (lambda (_) nil)) + ((symbol-function 'get-scratch-buffer-create) (lambda () 'scratch)) + ((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard))) + (should (eq (cj/--split-companion-buffer) 'dashboard)))) + +(ert-deftest test-ui-navigation-dashboard-buffer-returns-existing () + "Boundary: cj/--dashboard-buffer returns an existing *dashboard* without opening." + (let ((db (get-buffer-create "*dashboard*")) + (opened nil)) + (unwind-protect + (cl-letf (((symbol-function 'dashboard-open) + (lambda (&rest _) (setq opened t)))) + (should (eq (cj/--dashboard-buffer) db)) + (should-not opened)) + (kill-buffer db)))) + +(provide 'test-ui-navigation--split-dashboard) +;;; test-ui-navigation--split-dashboard.el ends here diff --git a/tests/test-ui-navigation--window-resize.el b/tests/test-ui-navigation--window-resize.el index 3be0313b8..553219755 100644 --- a/tests/test-ui-navigation--window-resize.el +++ b/tests/test-ui-navigation--window-resize.el @@ -24,8 +24,11 @@ (should (eq (keymap-lookup cj/window-resize-map "<down>") #'windsize-down))) (ert-deftest test-ui-navigation-window-resize-sticky-dispatches-and-arms () - "Normal: `cj/window-resize-sticky' runs the `windsize' command matching the -arrow key that triggered it, then arms the sticky-repeat map." + "Normal: with more than one window, `cj/window-resize-sticky' runs the +`windsize' command matching the arrow key that triggered it, then arms the +sticky-repeat map. `one-window-p' is forced nil so the resize path is taken +deterministically -- in `--batch' the sole frame is one-window-p, which would +otherwise route to the pull-away path." (dolist (case '((left . windsize-left) (right . windsize-right) (up . windsize-up) @@ -33,13 +36,45 @@ arrow key that triggered it, then arms the sticky-repeat map." (let ((ran nil) (overriding-terminal-local-map nil) (pre-command-hook nil)) - (cl-letf (((symbol-function (cdr case)) + (cl-letf (((symbol-function 'one-window-p) (lambda (&rest _) nil)) + ((symbol-function (cdr case)) (lambda (&rest _) (interactive) (setq ran t)))) (let ((last-command-event (car case))) (cj/window-resize-sticky))) (should ran) ; dispatched to the right command (should overriding-terminal-local-map)))) ; loop armed +(ert-deftest test-ui-navigation-window-pull-side () + "Normal/Error: each arrow maps to the *opposite* side (where the revealed +window opens, so the current window keeps the arrow's edge); anything else +is nil." + (should (eq (cj/window-pull-side "<down>") 'above)) + (should (eq (cj/window-pull-side "<up>") 'below)) + (should (eq (cj/window-pull-side "<left>") 'right)) + (should (eq (cj/window-pull-side "<right>") 'left)) + (should (null (cj/window-pull-side "<prior>"))) + (should (null (cj/window-pull-side "x")))) + +(ert-deftest test-ui-navigation-window-resize-sticky-sole-window-pulls-away () + "Normal: with a single window, the arrow pulls a sliver away on the side +opposite the arrow (via `cj/window--pull-away') rather than resizing, then +arms the loop. `cj/window--pull-away' is stubbed to capture the side so no +real window split happens under `--batch'." + (dolist (case '((down . above) + (up . below) + (left . right) + (right . left))) + (let ((pulled nil) + (overriding-terminal-local-map nil) + (pre-command-hook nil)) + (cl-letf (((symbol-function 'one-window-p) (lambda (&rest _) t)) + ((symbol-function 'cj/window--pull-away) + (lambda (dir) (setq pulled dir)))) + (let ((last-command-event (car case))) + (cj/window-resize-sticky))) + (should (eq pulled (cdr case))) ; pulled toward the arrow + (should overriding-terminal-local-map)))) ; loop armed + (ert-deftest test-ui-navigation-window-resize-bound-under-c-semicolon-b () "Normal: `C-; b <arrow>' (each direction) reaches the sticky-resize command." (require 'custom-buffer-file) diff --git a/tests/test-ui-navigation-split-follow-undo-kill.el b/tests/test-ui-navigation-split-follow-undo-kill.el index 8e3900743..f6981a36a 100644 --- a/tests/test-ui-navigation-split-follow-undo-kill.el +++ b/tests/test-ui-navigation-split-follow-undo-kill.el @@ -76,6 +76,29 @@ non-visited entry, not the second." (when (get-buffer "*test-alive*") (kill-buffer "*test-alive*")))) (should (equal opened "/tmp/dead.org")))) +(ert-deftest test-ui-navigation-undo-kill-buffer-skips-open-file-at-head () + "Boundary: an open file at the head of the list is skipped (equal, not eq). +The previous delq compared expand-file-name strings by identity, so a +currently-open most-recent file was never skipped." + (let ((opened nil) + (recentf-mode t) + ;; The open file is FIRST — only an equal-based filter removes it. + (recentf-list '("/tmp/alive.txt" "/tmp/dead.org"))) + (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) + ((symbol-function 'recentf-mode) (lambda (&rest _) t)) + ((symbol-function 'buffer-list) + (lambda (&rest _) + (list (let ((b (get-buffer-create "*test-alive*"))) + (with-current-buffer b + (setq buffer-file-name "/tmp/alive.txt")) + b)))) + ((symbol-function 'find-file) + (lambda (f) (setq opened f)))) + (unwind-protect + (cj/undo-kill-buffer 1) + (when (get-buffer "*test-alive*") (kill-buffer "*test-alive*")))) + (should (equal opened "/tmp/dead.org")))) + (ert-deftest test-ui-navigation-undo-kill-buffer-numeric-arg-is-one-based () "Normal: a numeric prefix is 1-based — N=2 opens the second non-visited entry." (let ((opened nil) diff --git a/tests/test-ui-theme-commands.el b/tests/test-ui-theme-commands.el index 55facc17e..1b273cf57 100644 --- a/tests/test-ui-theme-commands.el +++ b/tests/test-ui-theme-commands.el @@ -7,7 +7,6 @@ ;; cj/switch-themes ;; cj/save-theme-to-file ;; cj/get-active-theme-name -;; cj/load-fallback-theme ;;; Code: @@ -36,13 +35,11 @@ ;;; fallback-theme-name default -(ert-deftest test-ui-theme-default-fallback-is-bundled-dupre () - "Normal: the default fallback theme is dupre, the config's bundled theme. -modus-vivendi ships with Emacs but has no chosen dimming colors; dupre is -bundled in themes/, so it is available on every machine that loads this -config and is the right default fallback. Its loadability is covered by -test-dupre-theme.el." - (should (equal "dupre" (default-value 'fallback-theme-name)))) +(ert-deftest test-ui-theme-default-fallback-is-builtin-modus () + "Normal: the default fallback theme is modus-vivendi. +The fallback has no further fallback, so it must be present everywhere this +config loads. modus-vivendi ships with Emacs, so it always resolves." + (should (equal "modus-vivendi" (default-value 'fallback-theme-name)))) ;;; cj/save-theme-to-file @@ -70,23 +67,6 @@ does not raise." (cj/save-theme-to-file)) (should (string-match-p "Cannot save theme" messaged)))) -;;; cj/load-fallback-theme - -(ert-deftest test-ui-theme-load-fallback-disables-then-loads () - "Normal: load-fallback-theme disables all then loads the fallback." - (let ((fallback-theme-name "modus-vivendi") - (custom-enabled-themes '(old-one old-two)) - disabled loaded) - (cl-letf (((symbol-function 'disable-theme) - (lambda (theme) (push theme disabled))) - ((symbol-function 'load-theme) - (lambda (theme &optional _no-confirm _no-enable) - (push theme loaded))) - ((symbol-function 'message) #'ignore)) - (cj/load-fallback-theme "boom")) - (should (equal (sort (copy-sequence disabled) #'string<) '(old-one old-two))) - (should (equal loaded '(modus-vivendi))))) - ;;; cj/switch-themes (ert-deftest test-ui-theme-switch-disables-loads-then-saves () diff --git a/tests/test-ui-theme-persistence.el b/tests/test-ui-theme-persistence.el index 31e0e6cc8..02bb105a6 100644 --- a/tests/test-ui-theme-persistence.el +++ b/tests/test-ui-theme-persistence.el @@ -46,12 +46,12 @@ (lambda (&rest _args) (setq write-file-called t) (error "write-file should not be used")))) - (should (cj/theme-write-file-contents "dupre" file))) + (should (cj/theme-write-file-contents "modus-vivendi" file))) (delete-file file)) (should (equal (list (car write-region-args) (cadr write-region-args) (nth 2 write-region-args)) - (list "dupre" nil file))) + (list "modus-vivendi" nil file))) (should-not write-file-called))) (ert-deftest test-ui-theme-load-valid-persisted-theme () diff --git a/tests/test-user-constants.el b/tests/test-user-constants.el index 8dd9284ff..0c12eecf4 100644 --- a/tests/test-user-constants.el +++ b/tests/test-user-constants.el @@ -120,5 +120,48 @@ The whole point of the split — a bare require must not touch the filesystem." (should (eq (nth 1 warn-args) :error))) (delete-directory dir t)))) +;;; verify-or-create no-op branches (target already present) + +(ert-deftest test-user-constants-verify-dir-existing-is-noop () + "Boundary: an existing directory is a no-op — make-directory is not called." + (test-user-constants--load) + (let ((dir (make-temp-file "uc-exdir-" t))) + (unwind-protect + (cl-letf (((symbol-function 'make-directory) + (lambda (&rest _) (error "should not create an existing dir")))) + (cj/verify-or-create-dir dir) ; must not error + (should (file-directory-p dir))) + (delete-directory dir t)))) + +(ert-deftest test-user-constants-verify-file-existing-is-noop () + "Boundary: an existing file is left untouched — write-region is not called." + (test-user-constants--load) + (let* ((dir (make-temp-file "uc-exfile-" t)) + (file (expand-file-name "keep.org" dir))) + (unwind-protect + (progn + (with-temp-file file (insert "original")) + (cl-letf (((symbol-function 'write-region) + (lambda (&rest _) (error "should not overwrite an existing file")))) + (cj/verify-or-create-file file) + (should (equal (with-temp-buffer + (insert-file-contents file) (buffer-string)) + "original")))) + (delete-directory dir t)))) + +(ert-deftest test-user-constants-verify-file-optional-failure-logs () + "Error: an optional file failure is logged, never warned or signalled." + (test-user-constants--load) + (let ((dir (make-temp-file "uc-optfile-" t)) + (warned nil) (messaged nil)) + (unwind-protect + (cl-letf (((symbol-function 'write-region) (lambda (&rest _) (error "boom"))) + ((symbol-function 'display-warning) (lambda (&rest _) (setq warned t))) + ((symbol-function 'message) (lambda (&rest _) (setq messaged t)))) + (cj/verify-or-create-file (expand-file-name "optional.org" dir)) + (should messaged) + (should-not warned)) + (delete-directory dir t)))) + (provide 'test-user-constants) ;;; test-user-constants.el ends here |