diff options
Diffstat (limited to 'tests')
119 files changed, 3211 insertions, 543 deletions
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-commands.el b/tests/test-ai-config-commands.el index 8da2e4b01..fed06d82b 100644 --- a/tests/test-ai-config-commands.el +++ b/tests/test-ai-config-commands.el @@ -86,7 +86,7 @@ globally and reports via `message'." added) (unwind-protect (cl-letf (((symbol-function 'featurep) - (lambda (sym) (not (eq sym 'projectile)))) + (lambda (sym &rest _) (not (eq sym 'projectile)))) ((symbol-function 'read-file-name) (lambda (&rest _) target)) ((symbol-function 'gptel-add-file) @@ -133,7 +133,7 @@ globally and reports via `message'." (cl-letf (((symbol-function 'gptel-context-remove-all) (lambda () (setq called t))) ((symbol-function 'call-interactively) - (lambda (fn) (funcall fn))) + (lambda (fn &rest _) (funcall fn))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) (cj/gptel-context-clear)) diff --git a/tests/test-ai-config-gptel-commands.el b/tests/test-ai-config-gptel-commands.el index 371a75cc8..cab23572e 100644 --- a/tests/test-ai-config-gptel-commands.el +++ b/tests/test-ai-config-gptel-commands.el @@ -128,7 +128,7 @@ (ert-deftest test-ai-config-add-this-buffer-calls-gptel-add-with-prefix () "Normal: `cj/gptel-add-this-buffer' calls `gptel-add' with the (4) prefix arg." (let ((arg nil)) - (cl-letf (((symbol-function 'featurep) (lambda (_) t)) + (cl-letf (((symbol-function 'featurep) (lambda (_ &rest _) t)) ((symbol-function 'gptel-add) (lambda (a) (setq arg a))) ((symbol-function 'message) #'ignore)) @@ -144,7 +144,7 @@ (deleted nil)) (unwind-protect (cl-letf (((symbol-function 'get-buffer-window) - (lambda (_b) 'fake-window)) + (lambda (_b &rest _) 'fake-window)) ((symbol-function 'delete-window) (lambda (w) (setq deleted w)))) (cj/toggle-gptel)) 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 91013862d..1180c1979 100644 --- a/tests/test-ai-term--default-geometry.el +++ b/tests/test-ai-term--default-geometry.el @@ -1,18 +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 chosen from the frame's pixel aspect -;; ratio: a landscape frame docks the agent from the right (a width fraction), a -;; square or portrait frame docks it from the bottom (a height fraction). -;; `cj/--ai-term-direction-for-aspect' is the pure decision; -;; `cj/--ai-term-default-direction' reads the frame and delegates to it; -;; `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'. +;; 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'. ;; -;; The direction is tested on the pure helper (no frame mocking, which would -;; trip the native-comp trampoline trap on the frame-pixel-* subrs); the size -;; helper is tested by stubbing the direction defun. +;; 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: @@ -22,17 +24,26 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'ai-term) -(ert-deftest test-ai-term--direction-for-aspect-landscape-is-right () - "Normal: a wider-than-tall frame docks from the right." - (should (eq (cj/--ai-term-direction-for-aspect 1920 1080) 'right))) +(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--direction-for-aspect-portrait-is-below () - "Normal: a taller-than-wide frame docks from the bottom." - (should (eq (cj/--ai-term-direction-for-aspect 1080 1920) 'below))) - -(ert-deftest test-ai-term--direction-for-aspect-square-is-below () - "Boundary: a square frame docks from the bottom (the conserving tie-break)." - (should (eq (cj/--ai-term-direction-for-aspect 1000 1000) 'below))) +(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-pairs-width-with-right () "Normal: when the direction is `right' the size is the width fraction." diff --git a/tests/test-ai-term--f9-in-term.el b/tests/test-ai-term--f9-in-term.el index dad11ffc0..0477f2517 100644 --- a/tests/test-ai-term--f9-in-term.el +++ b/tests/test-ai-term--f9-in-term.el @@ -26,27 +26,29 @@ (should (eq (keymap-lookup ghostel-mode-map "<f9>") #'cj/ai-term))) (ert-deftest test-ai-term-f9-family-bound-in-ghostel-mode-map () - "Normal: the C-/M-/C-S- F9 variants are bound in `ghostel-mode-map' too. -`M-<f9>' and `C-S-<f9>' both close an agent via `cj/ai-term-close'." + "Normal: the C-/s-/M- F9 variants are bound in `ghostel-mode-map' too. +`s-<f9>' steps to the next agent; `M-<f9>' closes an agent via +`cj/ai-term-close'." (should (eq (keymap-lookup ghostel-mode-map "C-<f9>") #'cj/ai-term-pick-project)) - (should (eq (keymap-lookup ghostel-mode-map "M-<f9>") #'cj/ai-term-close)) - (should (eq (keymap-lookup ghostel-mode-map "C-S-<f9>") #'cj/ai-term-close))) + (should (eq (keymap-lookup ghostel-mode-map "s-<f9>") #'cj/ai-term-next)) + (should (eq (keymap-lookup ghostel-mode-map "M-<f9>") #'cj/ai-term-close))) (ert-deftest test-ai-term-f9-still-bound-globally () "Normal: the global F9 family bindings are intact. `<f9>' toggles the ai-term agent window; `C-<f9>' picks a project -agent; `M-<f9>' and `C-S-<f9>' close an agent via `cj/ai-term-close'." +agent; `s-<f9>' steps to the next agent; `M-<f9>' closes an agent +via `cj/ai-term-close'." (should (eq (lookup-key (current-global-map) (kbd "<f9>")) #'cj/ai-term)) (should (eq (lookup-key (current-global-map) (kbd "C-<f9>")) #'cj/ai-term-pick-project)) - (should (eq (lookup-key (current-global-map) (kbd "M-<f9>")) #'cj/ai-term-close)) - (should (eq (lookup-key (current-global-map) (kbd "C-S-<f9>")) #'cj/ai-term-close))) + (should (eq (lookup-key (current-global-map) (kbd "s-<f9>")) #'cj/ai-term-next)) + (should (eq (lookup-key (current-global-map) (kbd "M-<f9>")) #'cj/ai-term-close))) (ert-deftest test-ai-term-f9-family-in-keymap-exceptions () "Regression: the F9 family is in `ghostel-keymap-exceptions' so semi-char mode lets it reach Emacs instead of forwarding it to the terminal program. Binding in `ghostel-mode-map' alone is not enough -- the semi-char map outranks it and forwards any key not in the exceptions to the pty." - (dolist (key '("<f9>" "C-<f9>" "M-<f9>" "C-S-<f9>")) + (dolist (key '("<f9>" "C-<f9>" "s-<f9>" "M-<f9>")) (should (member key ghostel-keymap-exceptions))) ;; The rebuilt semi-char map must no longer forward <f9> to the pty. (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "<f9>") diff --git a/tests/test-ai-term--next-agent-buffer.el b/tests/test-ai-term--next-agent-buffer.el new file mode 100644 index 000000000..330714a92 --- /dev/null +++ b/tests/test-ai-term--next-agent-buffer.el @@ -0,0 +1,73 @@ +;;; test-ai-term--next-agent-buffer.el --- Tests for cj/--ai-term-next-agent-buffer -*- lexical-binding: t; -*- + +;;; Commentary: +;; The pure decision helper behind `cj/ai-term-next' (s-F9). Given the +;; current agent buffer and the ordered list of live agent buffers, it +;; returns the next buffer in the queue, wrapping after the last. A nil +;; or non-member CURRENT returns the first; an empty list returns nil. +;; No buffer or window side effects -- list logic only. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(ert-deftest test-ai-term--next-agent-buffer-advances-from-first () + "Normal: current is the first element -> returns the second." + (let ((a (get-buffer-create "agent [a]")) + (b (get-buffer-create "agent [b]")) + (c (get-buffer-create "agent [c]"))) + (unwind-protect + (should (eq b (cj/--ai-term-next-agent-buffer a (list a b c)))) + (mapc #'kill-buffer (list a b c))))) + +(ert-deftest test-ai-term--next-agent-buffer-advances-from-middle () + "Normal: current in the middle -> returns the following element." + (let ((a (get-buffer-create "agent [a]")) + (b (get-buffer-create "agent [b]")) + (c (get-buffer-create "agent [c]"))) + (unwind-protect + (should (eq c (cj/--ai-term-next-agent-buffer b (list a b c)))) + (mapc #'kill-buffer (list a b c))))) + +(ert-deftest test-ai-term--next-agent-buffer-wraps-after-last () + "Boundary: current is the last element -> wraps to the first." + (let ((a (get-buffer-create "agent [a]")) + (b (get-buffer-create "agent [b]")) + (c (get-buffer-create "agent [c]"))) + (unwind-protect + (should (eq a (cj/--ai-term-next-agent-buffer c (list a b c)))) + (mapc #'kill-buffer (list a b c))))) + +(ert-deftest test-ai-term--next-agent-buffer-single-element-returns-itself () + "Boundary: a one-agent queue wraps current back to itself." + (let ((a (get-buffer-create "agent [a]"))) + (unwind-protect + (should (eq a (cj/--ai-term-next-agent-buffer a (list a)))) + (kill-buffer a)))) + +(ert-deftest test-ai-term--next-agent-buffer-nil-current-returns-first () + "Boundary: nil current (no agent displayed) -> returns the first." + (let ((a (get-buffer-create "agent [a]")) + (b (get-buffer-create "agent [b]"))) + (unwind-protect + (should (eq a (cj/--ai-term-next-agent-buffer nil (list a b)))) + (mapc #'kill-buffer (list a b))))) + +(ert-deftest test-ai-term--next-agent-buffer-non-member-current-returns-first () + "Error: current not in the queue -> returns the first rather than nil." + (let ((a (get-buffer-create "agent [a]")) + (b (get-buffer-create "agent [b]")) + (stray (get-buffer-create "agent [stray]"))) + (unwind-protect + (should (eq a (cj/--ai-term-next-agent-buffer stray (list a b)))) + (mapc #'kill-buffer (list a b stray))))) + +(ert-deftest test-ai-term--next-agent-buffer-empty-queue-returns-nil () + "Boundary: an empty queue returns nil (nothing to switch to)." + (should (null (cj/--ai-term-next-agent-buffer nil '())))) + +(provide 'test-ai-term--next-agent-buffer) +;;; test-ai-term--next-agent-buffer.el ends here diff --git a/tests/test-ai-term--reuse-edge-window.el b/tests/test-ai-term--reuse-edge-window.el index f6259ae50..a9a0529e8 100644 --- a/tests/test-ai-term--reuse-edge-window.el +++ b/tests/test-ai-term--reuse-edge-window.el @@ -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 6c2fa3cf5..8793da73a 100644 --- a/tests/test-build-theme.el +++ b/tests/test-build-theme.el @@ -95,43 +95,175 @@ drift 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) @@ -355,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-calibredb-epub-config.el b/tests/test-calibredb-epub-config.el index 48d638358..cb3a9ba74 100644 --- a/tests/test-calibredb-epub-config.el +++ b/tests/test-calibredb-epub-config.el @@ -29,8 +29,8 @@ `(with-temp-buffer (setq-local major-mode 'nov-mode) (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 200)) - ((symbol-function 'window-margins) (lambda (_) '(nil . nil))) + ((symbol-function 'window-body-width) (lambda (&rest _) 200)) + ((symbol-function 'window-margins) (lambda (&rest _) '(nil . nil))) ((symbol-function 'set-window-margins) (lambda (&rest _) nil)) ((symbol-function 'set-window-fringes) (lambda (&rest _) nil))) ,@body))) @@ -73,8 +73,8 @@ below 50% of the usable columns." (let ((cj/nov-margin-percent 25) (cj/nov-min-text-width 40)) (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 120)) - ((symbol-function 'window-margins) (lambda (_) '(nil . nil)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 120)) + ((symbol-function 'window-margins) (lambda (&rest _) '(nil . nil)))) (should (= 60 (cj/nov--text-width-for-window)))))) (ert-deftest test-calibredb-epub-nov-text-width-for-window-idempotent () @@ -85,8 +85,8 @@ this, every layout pass would shave the column by another margin fraction." (let ((cj/nov-margin-percent 25) (cj/nov-min-text-width 40)) (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 60)) - ((symbol-function 'window-margins) (lambda (_) '(30 . 30)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 60)) + ((symbol-function 'window-margins) (lambda (&rest _) '(30 . 30)))) (should (= 60 (cj/nov--text-width-for-window)))))) (ert-deftest test-calibredb-epub-nov-text-width-for-window-no-window () @@ -214,15 +214,15 @@ so nov's `shr' fills the text itself rather than relying on visual-fill-column." (ert-deftest test-calibredb-epub-nov-natural-window-width-no-margins () "Normal: with no margins set, the natural width equals `window-body-width'." (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 100)) - ((symbol-function 'window-margins) (lambda (_) '(nil . nil)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 100)) + ((symbol-function 'window-margins) (lambda (&rest _) '(nil . nil)))) (should (= 100 (cj/nov--natural-window-width))))) (ert-deftest test-calibredb-epub-nov-natural-window-width-adds-margins () "Boundary: with margins set, the natural width adds them back to the body." (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 60)) - ((symbol-function 'window-margins) (lambda (_) '(20 . 20)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 60)) + ((symbol-function 'window-margins) (lambda (&rest _) '(20 . 20)))) (should (= 100 (cj/nov--natural-window-width))))) (ert-deftest test-calibredb-epub-nov-natural-window-width-no-window-fallback () 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-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-config-utilities--compile-this-elisp-buffer.el b/tests/test-config-utilities--compile-this-elisp-buffer.el index fb5e288a1..a06440abb 100644 --- a/tests/test-config-utilities--compile-this-elisp-buffer.el +++ b/tests/test-config-utilities--compile-this-elisp-buffer.el @@ -21,7 +21,7 @@ effects." (declare (indent 1) (debug t)) `(with-temp-buffer (setq buffer-file-name ,path) - (cl-letf (((symbol-function 'save-buffer) (lambda () nil))) + (cl-letf (((symbol-function 'save-buffer) (lambda (&rest _) nil))) ,@body))) (ert-deftest test-config-utilities-compile-buffer-not-elisp-raises () @@ -47,7 +47,7 @@ effects." ((symbol-function 'native-compile) (lambda (_) (error "should not call sync native-compile"))) ((symbol-function 'byte-compile-file) - (lambda (_) (error "should not call byte-compile-file")))) + (lambda (&rest _) (error "should not call byte-compile-file")))) (cj/compile-this-elisp-buffer) (should (equal called-with "/tmp/some.el")))))) @@ -60,7 +60,7 @@ effects." ((symbol-function 'native-compile) (lambda (file) (setq called-with file))) ((symbol-function 'byte-compile-file) - (lambda (_) (error "should not call byte-compile-file")))) + (lambda (&rest _) (error "should not call byte-compile-file")))) (cj/compile-this-elisp-buffer) (should (equal called-with "/tmp/some.el")))))) @@ -71,7 +71,7 @@ effects." (cl-letf (((symbol-function 'fboundp) (lambda (sym) (eq sym 'byte-compile-file))) ((symbol-function 'byte-compile-file) - (lambda (file) (setq called-with file) "/tmp/some.elc"))) + (lambda (file &rest _) (setq called-with file) "/tmp/some.elc"))) (cj/compile-this-elisp-buffer) (should (equal called-with "/tmp/some.el")))))) 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-coverage-core--relativize-keys.el b/tests/test-coverage-core--relativize-keys.el new file mode 100644 index 000000000..82031cd15 --- /dev/null +++ b/tests/test-coverage-core--relativize-keys.el @@ -0,0 +1,123 @@ +;;; test-coverage-core--relativize-keys.el --- Tests for path-key normalization -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit + integration tests for `cj/--coverage-relativize-keys', the helper +;; that normalizes a file-path-keyed coverage table to repo-relative paths. +;; +;; The bug it fixes: `cj/--coverage-parse-simplecov' returns ABSOLUTE path +;; keys (simplecov/undercover emit absolute source paths), while +;; `cj/--coverage-parse-diff-output' returns repo-RELATIVE keys (git's +;; "+++ b/<path>"). `cj/--coverage-intersect' joins the two by exact string +;; key, so for the diff-aware scopes every changed file was classified +;; ":tracked nil" — zero matches ever. Normalizing both tables to +;; repo-relative before the intersect makes the join work. +;; +;; The integration test drives the real parsers (a simplecov JSON fixture +;; with an absolute key + a git-diff string with the relative key) through +;; relativize + intersect, and asserts the file is tracked with the right +;; covered/uncovered split — the end-to-end reproduction of the bug. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'coverage-core) + +(defun test-coverage-relativize--hash-of-lines (pairs) + "Build a file → line-set hash table from PAIRS. +Each pair is (FILE . (LINES...)); LINES becomes a hash-table of line → t." + (let ((result (make-hash-table :test 'equal))) + (dolist (pair pairs) + (let ((lines (make-hash-table :test 'eql))) + (dolist (line (cdr pair)) + (puthash line t lines)) + (puthash (car pair) lines result))) + result)) + +;;; Normal cases + +(ert-deftest test-coverage-relativize-absolute-key-made-relative () + "Normal: an absolute key is relativized against ROOT." + (let* ((table (test-coverage-relativize--hash-of-lines + '(("/home/u/.emacs.d/modules/foo.el" 10 11)))) + (out (cj/--coverage-relativize-keys table "/home/u/.emacs.d"))) + (should (gethash "modules/foo.el" out)) + (should (null (gethash "/home/u/.emacs.d/modules/foo.el" out))))) + +(ert-deftest test-coverage-relativize-preserves-line-set () + "Normal: the line-set value travels unchanged to the new key." + (let* ((table (test-coverage-relativize--hash-of-lines + '(("/r/modules/foo.el" 4 8 15)))) + (out (cj/--coverage-relativize-keys table "/r")) + (lines (gethash "modules/foo.el" out))) + (should (hash-table-p lines)) + (should (gethash 4 lines)) + (should (gethash 8 lines)) + (should (gethash 15 lines)))) + +;;; Boundary cases + +(ert-deftest test-coverage-relativize-already-relative-unchanged () + "Boundary: an already-relative key is left as-is, not re-relativized." + (let* ((table (test-coverage-relativize--hash-of-lines + '(("modules/foo.el" 1 2)))) + (out (cj/--coverage-relativize-keys table "/home/u/.emacs.d"))) + (should (gethash "modules/foo.el" out)) + (should (= 1 (hash-table-count out))))) + +(ert-deftest test-coverage-relativize-empty-table () + "Boundary: an empty table yields an empty table." + (let ((out (cj/--coverage-relativize-keys (make-hash-table :test 'equal) "/r"))) + (should (hash-table-p out)) + (should (= 0 (hash-table-count out))))) + +;;; Error cases + +(ert-deftest test-coverage-relativize-nil-table-returns-empty () + "Error: a nil table returns an empty table rather than erroring." + (let ((out (cj/--coverage-relativize-keys nil "/r"))) + (should (hash-table-p out)) + (should (= 0 (hash-table-count out))))) + +;;; Integration — the real bug reproduction + +(ert-deftest test-coverage-integration-absolute-report-relative-diff-tracks () + "Integration: a simplecov report (absolute keys) and a git diff (relative +keys) for the same file intersect as TRACKED once both are relativized. +This is the diff-aware-scope bug: without normalization the file reads +\":tracked nil\"." + (let* ((root "/tmp/cov-root") + (abs-path (concat root "/modules/foo.el")) + (report (make-temp-file "cov-report-" nil ".json")) + (diff (concat + "diff --git a/modules/foo.el b/modules/foo.el\n" + "index 1111111..2222222 100644\n" + "--- a/modules/foo.el\n" + "+++ b/modules/foo.el\n" + "@@ -2,0 +2,3 @@\n" + "+line two\n" + "+line three\n" + "+line four\n"))) + (unwind-protect + (progn + ;; simplecov array: index1=null, 2=hit, 3=0-hits, 4=hit + ;; → covered lines {2, 4} + (with-temp-file report + (insert (format "{\"t\":{\"coverage\":{%S:[null,1,0,2]}}}" abs-path))) + (let* ((covered (cj/--coverage-relativize-keys + (cj/--coverage-parse-simplecov report) root)) + (changed (cj/--coverage-relativize-keys + (cj/--coverage-parse-diff-output diff) root)) + (records (cj/--coverage-intersect covered changed)) + (record (car records))) + (should (= 1 (length records))) + (should (equal "modules/foo.el" (plist-get record :path))) + (should (eq t (plist-get record :tracked))) + (should (equal '(2 3 4) (plist-get record :changed-lines))) + (should (equal '(2 4) (plist-get record :covered-lines))) + (should (equal '(3) (plist-get record :uncovered-lines))))) + (delete-file report)))) + +(provide 'test-coverage-core--relativize-keys) +;;; test-coverage-core--relativize-keys.el ends here diff --git a/tests/test-custom-buffer-file-print-diff-eww.el b/tests/test-custom-buffer-file-print-diff-eww.el index 9aa73cbee..56cc917e0 100644 --- a/tests/test-custom-buffer-file-print-diff-eww.el +++ b/tests/test-custom-buffer-file-print-diff-eww.el @@ -30,14 +30,14 @@ (let ((cj/print-spooler-command "lpr") (cj/print--spooler-cache nil)) (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lpr") "/usr/bin/lpr")))) + (lambda (cmd &rest _) (when (equal cmd "lpr") "/usr/bin/lpr")))) (should (equal (cj/print--resolve-spooler) "lpr"))))) (ert-deftest test-cbf-resolve-spooler-explicit-string-missing-errors () "Error: explicit string spooler not on PATH signals user-error." (let ((cj/print-spooler-command "notathing") (cj/print--spooler-cache nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/print--resolve-spooler) :type 'user-error)))) (ert-deftest test-cbf-resolve-spooler-auto-detects-lpr-first () @@ -45,7 +45,7 @@ (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache nil)) (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lpr") "/usr/bin/lpr")))) + (lambda (cmd &rest _) (when (equal cmd "lpr") "/usr/bin/lpr")))) (should (equal (cj/print--resolve-spooler) "lpr")) (should (equal cj/print--spooler-cache "lpr"))))) @@ -54,14 +54,14 @@ (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache nil)) (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lp") "/usr/bin/lp")))) + (lambda (cmd &rest _) (when (equal cmd "lp") "/usr/bin/lp")))) (should (equal (cj/print--resolve-spooler) "lp"))))) (ert-deftest test-cbf-resolve-spooler-auto-no-tool-errors () "Error: `auto' with neither lpr nor lp signals user-error." (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/print--resolve-spooler) :type 'user-error)))) (ert-deftest test-cbf-resolve-spooler-auto-returns-cached-value () @@ -69,7 +69,7 @@ (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache "cached-cmd")) (cl-letf (((symbol-function 'executable-find) - (lambda (_) (error "should not be called")))) + (lambda (_ &rest _) (error "should not be called")))) (should (equal (cj/print--resolve-spooler) "cached-cmd"))))) (ert-deftest test-cbf-resolve-spooler-invalid-value-errors () @@ -87,7 +87,7 @@ (with-temp-buffer (rename-buffer "*test-cbf-copy-name*" t) (cl-letf (((symbol-function 'kill-new) - (lambda (s) (setq killed s))) + (lambda (s &rest _) (setq killed s))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) 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-dev-fkeys--f6-current-file-tests-impl.el b/tests/test-dev-fkeys--f6-current-file-tests-impl.el index 1cf222305..2d8e43858 100644 --- a/tests/test-dev-fkeys--f6-current-file-tests-impl.el +++ b/tests/test-dev-fkeys--f6-current-file-tests-impl.el @@ -111,7 +111,7 @@ runner instead of erroring as unsupported." (let ((compile-called nil)) (cl-letf (((symbol-function 'compile) (lambda (cmd) (setq compile-called cmd))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/--f6-current-file-tests-impl "/home/u/proj/src/foo.test.ts" "/home/u/proj/") (should (stringp compile-called)) diff --git a/tests/test-dev-fkeys--f6-current-file-tests.el b/tests/test-dev-fkeys--f6-current-file-tests.el index 3f6adc255..97c1c7675 100644 --- a/tests/test-dev-fkeys--f6-current-file-tests.el +++ b/tests/test-dev-fkeys--f6-current-file-tests.el @@ -16,7 +16,7 @@ (ert-deftest test-dev-fkeys-f6-current-file-tests-routes-to-impl () "Normal: C-F6 invokes the orchestrator with buffer file and projectile root." (let (seen-file seen-root) - (cl-letf (((symbol-function 'buffer-file-name) (lambda () "/p/foo.el")) + (cl-letf (((symbol-function 'buffer-file-name) (lambda (&rest _) "/p/foo.el")) ((symbol-function 'cj/--f4-project-root) (lambda () "/p/")) ((symbol-function 'cj/--f6-current-file-tests-impl) (lambda (file root) diff --git a/tests/test-dev-fkeys--f6-test-runner-cmd-for.el b/tests/test-dev-fkeys--f6-test-runner-cmd-for.el index 9a5526125..d7b6a0597 100644 --- a/tests/test-dev-fkeys--f6-test-runner-cmd-for.el +++ b/tests/test-dev-fkeys--f6-test-runner-cmd-for.el @@ -126,13 +126,13 @@ neither tool is present, the user gets a clear runner-not-found error rather than a silent nil that F6's outer wrapper interprets as \"language unsupported.\"" (cl-letf (((symbol-function 'executable-find) - (lambda (_) nil))) + (lambda (_ &rest _) nil))) (should (equal (cj/--f6-test-runner-cmd-for 'typescript t "src/foo.test.ts" "foo" "src") "npx --no-install jest src/foo.test.ts"))) (cl-letf (((symbol-function 'executable-find) - (lambda (p) (when (equal p "vitest") "/usr/bin/vitest")))) + (lambda (p &rest _) (when (equal p "vitest") "/usr/bin/vitest")))) (should (equal (cj/--f6-test-runner-cmd-for 'typescript t "src/foo.test.ts" "foo" "src") diff --git a/tests/test-dev-fkeys--f6-test-runner.el b/tests/test-dev-fkeys--f6-test-runner.el index eb9cec5ef..d5f58a66d 100644 --- a/tests/test-dev-fkeys--f6-test-runner.el +++ b/tests/test-dev-fkeys--f6-test-runner.el @@ -79,7 +79,7 @@ Components integrated: (lambda (&rest _) "Current file's tests")) ((symbol-function 'projectile-test-project) (lambda (_arg) nil)) ((symbol-function 'cj/--f4-project-root) (lambda () "/p/")) - ((symbol-function 'buffer-file-name) (lambda () "/p/foo.el")) + ((symbol-function 'buffer-file-name) (lambda (&rest _) "/p/foo.el")) ((symbol-function 'cj/--f6-current-file-tests-impl) (lambda (file root) (setq seen-file file seen-root root)))) diff --git a/tests/test-dev-fkeys--projectile-advice-install.el b/tests/test-dev-fkeys--projectile-advice-install.el index bfa9b691f..d0a9a9cc0 100644 --- a/tests/test-dev-fkeys--projectile-advice-install.el +++ b/tests/test-dev-fkeys--projectile-advice-install.el @@ -16,7 +16,7 @@ "When Projectile is not loaded, registration should use `eval-after-load'." (let (registered-feature registered-form install-called) (cl-letf (((symbol-function 'featurep) - (lambda (feature) (and (not (eq feature 'projectile)) + (lambda (feature &rest _) (and (not (eq feature 'projectile)) (featurep feature)))) ((symbol-function 'eval-after-load) (lambda (feature form) @@ -33,7 +33,7 @@ "When Projectile is already loaded, registration should install immediately." (let (install-called eval-after-load-called) (cl-letf (((symbol-function 'featurep) - (lambda (feature) (eq feature 'projectile))) + (lambda (feature &rest _) (eq feature 'projectile))) ((symbol-function 'eval-after-load) (lambda (&rest _args) (setq eval-after-load-called t))) ((symbol-function 'cj/--projectile-install-revert-advice) diff --git a/tests/test-dirvish-config-drill.el b/tests/test-dirvish-config-drill.el index f26de6d87..de0541a0c 100644 --- a/tests/test-dirvish-config-drill.el +++ b/tests/test-dirvish-config-drill.el @@ -34,7 +34,7 @@ "Normal: an `.org' file at point is opened and drilled." (let (opened (drilled 0)) (cl-letf (((symbol-function 'dired-get-filename) (lambda (&rest _) "/tmp/decks/cards.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'cj/drill-this-file) (lambda (&rest _) (cl-incf drilled)))) (cj/dirvish-drill-file)) (should (equal "/tmp/decks/cards.org" opened)) @@ -44,7 +44,7 @@ "Boundary: the `.org' check ignores case." (let (opened) (cl-letf (((symbol-function 'dired-get-filename) (lambda (&rest _) "/tmp/decks/CARDS.ORG")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'cj/drill-this-file) #'ignore)) (cj/dirvish-drill-file)) (should (equal "/tmp/decks/CARDS.ORG" opened)))) 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-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-popup.el b/tests/test-dirvish-config-popup.el new file mode 100644 index 000000000..2bd3a192c --- /dev/null +++ b/tests/test-dirvish-config-popup.el @@ -0,0 +1,248 @@ +;;; test-dirvish-config-popup.el --- Dirvish Hyprland popup tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the Hyprland Super+F dirvish popup. The launcher opens an +;; emacsclient frame named "dirvish" (window rules float/size/center it by that +;; name) and runs `cj/dirvish-popup', which opens Dirvish rooted at home. `q' +;; runs `cj/dirvish-popup-quit': in the popup frame it quits Dirvish and deletes +;; the frame; in any other frame it quits Dirvish normally. Covered here: frame +;; discovery by name, the emacsclient focus race on open, and the quit dispatch +;; on every frame condition. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'dirvish-config) + +;;; cj/--dirvish-popup-frame (find the popup frame by name) + +(ert-deftest test-dirvish-config-popup-frame-found () + "Normal: returns the live frame whose name is \"dirvish\"." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fb fc))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) + (lambda (f _p) (if (eq f 'fb) "dirvish" "other")))) + (should (eq (cj/--dirvish-popup-frame) 'fb)))) + +(ert-deftest test-dirvish-config-popup-frame-none () + "Boundary: no popup frame present yields nil." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fc))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) (lambda (_f _p) "other"))) + (should-not (cj/--dirvish-popup-frame)))) + +(ert-deftest test-dirvish-config-popup-frame-skips-dead () + "Boundary: a dead frame named \"dirvish\" is skipped." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fb))) + ((symbol-function 'frame-live-p) (lambda (f) (not (eq f 'fb)))) + ((symbol-function 'frame-parameter) (lambda (_f _p) "dirvish"))) + (should (eq (cj/--dirvish-popup-frame) 'fa)))) + +;;; cj/dirvish-popup (open dirvish in the named frame) + +(ert-deftest test-dirvish-config-popup-selects-named-frame () + "Integration: cj/dirvish-popup focuses the \"dirvish\" frame found by name, +not whatever frame happens to be selected (the emacsclient -c focus race). + +Components integrated: +- cj/dirvish-popup (real) +- cj/--dirvish-popup-frame (MOCKED — returns a sentinel frame) +- select-frame-set-input-focus (MOCKED — records the focused frame) +- dirvish (MOCKED — records the path opened)" + (let ((focused nil) (opened nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup-frame)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f))) + ((symbol-function 'dirvish) (lambda (&optional p) (setq opened (or p t))))) + (cj/dirvish-popup)) + (should (eq focused 'popup-frame)) + (should opened))) + +(ert-deftest test-dirvish-config-popup-no-frame-still-opens () + "Integration: with no popup frame found, cj/dirvish-popup skips the focus call +and still opens Dirvish (no error)." + (let ((focused 'unset) (opened nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f))) + ((symbol-function 'dirvish) (lambda (&optional _p) (setq opened t)))) + (cj/dirvish-popup)) + (should (eq focused 'unset)) + (should opened))) + +;;; cj/dirvish-popup-quit (quit; delete the popup frame only when in it) + +(ert-deftest test-dirvish-config-popup-quit-in-popup-deletes-frame () + "Normal: in the popup frame, q quits Dirvish and deletes the popup frame." + (let ((quit 0) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'popup)) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'dirvish-quit) (lambda () (cl-incf quit))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (= quit 1)) + (should (eq deleted 'popup)))) + +(ert-deftest test-dirvish-config-popup-quit-normal-frame-keeps-frame () + "Boundary: with no popup frame, q quits Dirvish and deletes nothing." + (let ((quit 0) (deleted 'unset)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'selected-frame) (lambda () 'main)) + ((symbol-function 'dirvish-quit) (lambda () (cl-incf quit))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (= quit 1)) + (should (eq deleted 'unset)))) + +(ert-deftest test-dirvish-config-popup-quit-popup-not-selected-keeps-frame () + "Boundary: the popup exists but a different frame is selected — q quits Dirvish +in that frame and does not delete the popup." + (let ((quit 0) (deleted 'unset)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'main)) + ((symbol-function 'dirvish-quit) (lambda () (cl-incf quit))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (= quit 1)) + (should (eq deleted 'unset)))) + +(ert-deftest test-dirvish-config-popup-quit-survives-dirvish-quit-error () + "Error: a signal from dirvish-quit in the popup still deletes the frame." + (let ((deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'popup)) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'dirvish-quit) (lambda () (error "boom"))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (eq deleted 'popup)))) + +;;; cj/dirvish-popup-focus-existing (second-launch re-use guard) + +(ert-deftest test-dirvish-config-popup-focus-existing-found () + "Normal: an existing popup is focused and t is returned." + (let ((focused nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f)))) + (should (eq (cj/dirvish-popup-focus-existing) t)) + (should (eq focused 'popup))))) + +(ert-deftest test-dirvish-config-popup-focus-existing-none () + "Boundary: no popup present — returns nil and focuses nothing." + (let ((focused 'unset)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f)))) + (should-not (cj/dirvish-popup-focus-existing)) + (should (eq focused 'unset))))) + +;;; cj/--dirvish-popup-selected-p + +(ert-deftest test-dirvish-config-popup-selected-p-true () + "Normal: true when the selected frame is the popup frame." + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'popup))) + (should (cj/--dirvish-popup-selected-p)))) + +(ert-deftest test-dirvish-config-popup-selected-p-false-other-frame () + "Boundary: false when a different frame is selected." + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'main))) + (should-not (cj/--dirvish-popup-selected-p)))) + +(ert-deftest test-dirvish-config-popup-selected-p-false-no-popup () + "Boundary: false when no popup frame exists." + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'selected-frame) (lambda () 'main))) + (should-not (cj/--dirvish-popup-selected-p)))) + +;;; cj/dirvish-popup-find-file (popup = launcher; outside = plain find-file) + +(ert-deftest test-dirvish-config-popup-find-file-in-popup-file-launches-external () + "Normal: in the popup, a file at point opens via cj/xdg-open, not in-frame." + (let ((opened nil) (visited nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-selected-p) (lambda () t)) + ((symbol-function 'dired-get-file-for-visit) (lambda () "/tmp/a.mp4")) + ((symbol-function 'file-directory-p) (lambda (_f) nil)) + ((symbol-function 'cj/xdg-open) (lambda (f) (setq opened f))) + ((symbol-function 'dired-find-file) (lambda () (setq visited t)))) + (cj/dirvish-popup-find-file)) + (should (equal opened "/tmp/a.mp4")) + (should-not visited))) + +(ert-deftest test-dirvish-config-popup-find-file-in-popup-dir-navigates () + "Boundary: in the popup, a directory at point is entered normally." + (let ((opened nil) (visited nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-selected-p) (lambda () t)) + ((symbol-function 'dired-get-file-for-visit) (lambda () "/tmp/dir/")) + ((symbol-function 'file-directory-p) (lambda (_f) t)) + ((symbol-function 'cj/xdg-open) (lambda (f) (setq opened f))) + ((symbol-function 'dired-find-file) (lambda () (setq visited t)))) + (cj/dirvish-popup-find-file)) + (should visited) + (should-not opened))) + +(ert-deftest test-dirvish-config-popup-find-file-outside-popup-is-plain-find-file () + "Boundary: outside the popup, behaves exactly like dired-find-file." + (let ((opened nil) (visited nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-selected-p) (lambda () nil)) + ((symbol-function 'cj/xdg-open) (lambda (f) (setq opened f))) + ((symbol-function 'dired-find-file) (lambda () (setq visited t)))) + (cj/dirvish-popup-find-file)) + (should visited) + (should-not opened))) + +;;; cj/--dirvish-popup-focus-watch (dismiss on focus loss, armed after focus) + +(ert-deftest test-dirvish-config-popup-focus-watch-focused-arms-flag () + "Normal: while the popup is focused, the watch sets the had-focus flag and +deletes nothing." + (let ((params '()) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'frame-focus-state) (lambda (_f) t)) + ((symbol-function 'frame-parameter) (lambda (_f p) (plist-get params p))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setq params (plist-put params p v)))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should (plist-get params 'cj-dirvish-popup-had-focus)) + (should-not deleted))) + +(ert-deftest test-dirvish-config-popup-focus-watch-unfocused-after-arming-deletes () + "Normal: lost focus after having held it — the popup is deleted." + (let ((params (list 'cj-dirvish-popup-had-focus t)) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'frame-focus-state) (lambda (_f) nil)) + ((symbol-function 'frame-parameter) (lambda (_f p) (plist-get params p))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setq params (plist-put params p v)))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should (eq deleted 'popup)))) + +(ert-deftest test-dirvish-config-popup-focus-watch-unfocused-before-arming-keeps () + "Boundary: not focused and never armed (the creation race) — NOT deleted." + (let ((params '()) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'frame-focus-state) (lambda (_f) nil)) + ((symbol-function 'frame-parameter) (lambda (_f p) (plist-get params p))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setq params (plist-put params p v)))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should-not deleted))) + +(ert-deftest test-dirvish-config-popup-focus-watch-no-popup-is-noop () + "Error: with no popup frame, the watch does nothing and doesn't raise." + (let ((deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should-not deleted))) + +(provide 'test-dirvish-config-popup) +;;; test-dirvish-config-popup.el ends here diff --git a/tests/test-dirvish-config-print.el b/tests/test-dirvish-config-print.el index ab6d073f0..308d00f68 100644 --- a/tests/test-dirvish-config-print.el +++ b/tests/test-dirvish-config-print.el @@ -50,18 +50,18 @@ (ert-deftest test-dirvish-print-program-prefers-lp () "Normal: `lp' is used when available." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lp") "/usr/bin/lp")))) + (lambda (cmd &rest _) (when (equal cmd "lp") "/usr/bin/lp")))) (should (equal (cj/--print-program) "/usr/bin/lp")))) (ert-deftest test-dirvish-print-program-falls-back-to-lpr () "Boundary: `lpr' is used when `lp' is missing." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lpr") "/usr/bin/lpr")))) + (lambda (cmd &rest _) (when (equal cmd "lpr") "/usr/bin/lpr")))) (should (equal (cj/--print-program) "/usr/bin/lpr")))) (ert-deftest test-dirvish-print-program-none-available () "Error: nil when neither `lp' nor `lpr' is on PATH." - (cl-letf (((symbol-function 'executable-find) (lambda (_cmd) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_cmd &rest _) nil))) (should-not (cj/--print-program)))) ;;; ---------------------------- cj/dirvish-print-file ------------------------- diff --git a/tests/test-dirvish-config-public-wrappers.el b/tests/test-dirvish-config-public-wrappers.el index cec979e4a..d1141d33a 100644 --- a/tests/test-dirvish-config-public-wrappers.el +++ b/tests/test-dirvish-config-public-wrappers.el @@ -124,7 +124,7 @@ confused when several built-ins are overridden in the same test." ((symbol-function 'cj/get-project-root) (lambda () nil)) ((symbol-function 'kill-new) - (lambda (s) (setq killed s))) + (lambda (s &rest _) (setq killed s))) ((symbol-function 'message) #'ignore)) (cj/dired-copy-path-as-kill)) (should (stringp killed)) @@ -139,7 +139,7 @@ confused when several built-ins are overridden in the same test." (lambda (&rest _) "/tmp/foo.txt")) ((symbol-function 'cj/get-project-root) (lambda () nil)) ((symbol-function 'kill-new) - (lambda (s) (setq killed s))) + (lambda (s &rest _) (setq killed s))) ((symbol-function 'message) #'ignore)) (cj/dired-copy-path-as-kill t)) (should (string-prefix-p "[[file:" killed)) diff --git a/tests/test-dirvish-config-wrappers.el b/tests/test-dirvish-config-wrappers.el index bead45830..39f272474 100644 --- a/tests/test-dirvish-config-wrappers.el +++ b/tests/test-dirvish-config-wrappers.el @@ -40,7 +40,7 @@ puts the older one first)." ((symbol-function 'ediff-files) (lambda (a b) (setq ediff-args (list a b)))) ((symbol-function 'current-window-configuration) - (lambda () nil)) + (lambda (&rest _) nil)) ((symbol-function 'add-hook) #'ignore)) (cj/dired-ediff-files) ;; Pair returns (older . newer) so ediff-files sees (older newer). diff --git a/tests/test-dwim-shell-config-command-fixes.el b/tests/test-dwim-shell-config-command-fixes.el index 2f49a868f..2cc3ae72b 100644 --- a/tests/test-dwim-shell-config-command-fixes.el +++ b/tests/test-dwim-shell-config-command-fixes.el @@ -29,5 +29,60 @@ so the substitution can't sit dead inside single quotes." (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-helpers.el b/tests/test-elfeed-config-helpers.el index 59a0ed331..16cbb7443 100644 --- a/tests/test-elfeed-config-helpers.el +++ b/tests/test-elfeed-config-helpers.el @@ -39,7 +39,7 @@ (ert-deftest test-elfeed-extract-stream-url-normal-returns-url () "Normal: a successful yt-dlp run returns the trimmed https stream URL." (cl-letf (((symbol-function 'executable-find) - (lambda (p) (and (equal p "yt-dlp") "/usr/bin/yt-dlp"))) + (lambda (p &rest _) (and (equal p "yt-dlp") "/usr/bin/yt-dlp"))) ((symbol-function 'cj/log-silently) #'ignore) ((symbol-function 'call-process) (lambda (_prog _infile _dest _disp &rest _args) @@ -49,7 +49,7 @@ (ert-deftest test-elfeed-extract-stream-url-boundary-non-url-output-is-nil () "Boundary: output that is not an http(s) URL yields nil, not the raw text." - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/yt-dlp")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/yt-dlp")) ((symbol-function 'cj/log-silently) #'ignore) ((symbol-function 'call-process) (lambda (_p _i _d _disp &rest _) (insert "ERROR: unavailable\n") 0))) @@ -57,7 +57,7 @@ (ert-deftest test-elfeed-extract-stream-url-boundary-nonzero-exit-is-nil () "Boundary: a nonzero yt-dlp exit code yields nil." - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/yt-dlp")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/yt-dlp")) ((symbol-function 'cj/log-silently) #'ignore) ((symbol-function 'call-process) (lambda (_p _i _d _disp &rest _) (insert "boom") 1))) @@ -65,7 +65,7 @@ (ert-deftest test-elfeed-extract-stream-url-error-without-yt-dlp () "Error: a missing yt-dlp signals before attempting the call." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/extract-stream-url "u" "best") :type 'error))) ;;; cj/elfeed-process-entries 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-flyspell-and-abbrev.el b/tests/test-flyspell-and-abbrev.el index 793fdc0f4..ef8cc6375 100644 --- a/tests/test-flyspell-and-abbrev.el +++ b/tests/test-flyspell-and-abbrev.el @@ -32,12 +32,12 @@ (ert-deftest test-flyspell-require-spell-checker-present () "Normal: a checker on PATH means no error." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (equal cmd (car cj/--spell-checker-executables))))) + (lambda (cmd &rest _) (equal cmd (car cj/--spell-checker-executables))))) (should-not (cj/--require-spell-checker)))) (ert-deftest test-flyspell-require-spell-checker-missing () "Error: no checker on PATH signals user-error." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/--require-spell-checker) :type 'user-error))) ;; --------------------- cj/find-previous-flyspell-overlay --------------------- 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-gptel-tools-web-fetch.el b/tests/test-gptel-tools-web-fetch.el index b6dbefccb..10abe6eba 100644 --- a/tests/test-gptel-tools-web-fetch.el +++ b/tests/test-gptel-tools-web-fetch.el @@ -106,13 +106,13 @@ (ert-deftest test-gptel-tools-web-fetch-html-to-text-error-when-neither-on-path () "Error: when neither pandoc nor w3m is on PATH, signals user-error." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/gptel-web-fetch--html-to-text "<p>x</p>")))) (ert-deftest test-gptel-tools-web-fetch-html-to-text-error-on-tool-failure () "Error: a failing HTML stripping command is reported." (cl-letf (((symbol-function 'executable-find) - (lambda (program) (and (equal program "pandoc") "/bin/pandoc"))) + (lambda (program &rest _) (and (equal program "pandoc") "/bin/pandoc"))) ((symbol-function 'call-process-region) (lambda (&rest _args) 9))) (should-error (cj/gptel-web-fetch--html-to-text "<p>x</p>")))) @@ -121,7 +121,7 @@ "Boundary: w3m is used when pandoc is unavailable." (let (called-program) (cl-letf (((symbol-function 'executable-find) - (lambda (program) (and (equal program "w3m") "/bin/w3m"))) + (lambda (program &rest _) (and (equal program "w3m") "/bin/w3m"))) ((symbol-function 'call-process-region) (lambda (start end program delete output display &rest _args) (setq called-program program) diff --git a/tests/test-host-environment--detect-system-timezone.el b/tests/test-host-environment--detect-system-timezone.el index c24ac183a..209283d1e 100644 --- a/tests/test-host-environment--detect-system-timezone.el +++ b/tests/test-host-environment--detect-system-timezone.el @@ -22,7 +22,7 @@ (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () "America/Los_Angeles")) ((symbol-function 'getenv) - (lambda (_) (error "TZ should not have been consulted")))) + (lambda (_ &rest _) (error "TZ should not have been consulted")))) (should (equal (cj/detect-system-timezone) "America/Los_Angeles")))) (ert-deftest test-host-environment-detect-tz-env-var-wins-when-match-nil () @@ -30,7 +30,7 @@ (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (name) (when (string= name "TZ") "Europe/Berlin")))) + (lambda (name &rest _) (when (string= name "TZ") "Europe/Berlin")))) (should (equal (cj/detect-system-timezone) "Europe/Berlin")))) (ert-deftest test-host-environment-detect-tz-falls-through-to-etc-timezone () @@ -41,7 +41,7 @@ contents primitives." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (_) nil)) + (lambda (_ &rest _) nil)) ((symbol-function 'file-exists-p) (lambda (path) (string= path "/etc/timezone"))) ((symbol-function 'insert-file-contents) @@ -55,7 +55,7 @@ contents primitives." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (_) nil)) + (lambda (_ &rest _) nil)) ((symbol-function 'file-exists-p) (lambda (path) (string= path "/etc/timezone"))) ((symbol-function 'insert-file-contents) @@ -69,10 +69,35 @@ contents primitives." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (_) nil)) + (lambda (_ &rest _) nil)) ((symbol-function 'file-exists-p) (lambda (_) nil)) ((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 (_ &rest _) nil)) + ((symbol-function 'file-exists-p) (lambda (_) nil)) + ((symbol-function 'file-symlink-p) + (lambda (path) (string= path "/etc/localtime"))) + ((symbol-function 'file-truename) + (lambda (_ &rest _) "/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 (_ &rest _) nil)) + ((symbol-function 'file-exists-p) (lambda (_) nil)) + ((symbol-function 'file-symlink-p) + (lambda (path) (string= path "/etc/localtime"))) + ((symbol-function 'file-truename) + (lambda (_ &rest _) "/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-host-environment--display-predicates.el b/tests/test-host-environment--display-predicates.el index 15dff2ef8..5a87b5009 100644 --- a/tests/test-host-environment--display-predicates.el +++ b/tests/test-host-environment--display-predicates.el @@ -26,7 +26,7 @@ GRAPHIC-P becomes the return of `(display-graphic-p)'." `(cl-letf (((symbol-function 'window-system) (lambda (&optional _) ,window-system-value)) ((symbol-function 'getenv) - (lambda (name) + (lambda (name &rest _) (when (string= name "WAYLAND_DISPLAY") ,wayland-display))) ((symbol-function 'display-graphic-p) (lambda (&optional _) ,graphic-p))) diff --git a/tests/test-hugo-config-commands.el b/tests/test-hugo-config-commands.el index 01df5fc18..07bc27ca3 100644 --- a/tests/test-hugo-config-commands.el +++ b/tests/test-hugo-config-commands.el @@ -134,7 +134,7 @@ stubbed before the org-mode-derived guard runs." ((symbol-function 'completing-read) (lambda (&rest _) "Foo Post")) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (cj/hugo-open-draft)) (should (equal opened "/tmp/foo.org")))) @@ -196,7 +196,7 @@ stubbed before the org-mode-derived guard runs." (msg nil)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) ((symbol-function 'kill-process) - (lambda (p) (setq killed p))) + (lambda (p &rest _) (setq killed p))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) @@ -210,7 +210,7 @@ stubbed before the org-mode-derived guard runs." (let ((cj/hugo--preview-process nil) (start-args nil)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'executable-find) (lambda (_) "/usr/bin/hugo")) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/hugo")) ((symbol-function 'start-process) (lambda (&rest args) (setq start-args args) @@ -226,7 +226,7 @@ stubbed before the org-mode-derived guard runs." "Error: a missing hugo binary signals user-error before start-process." (let ((cj/hugo--preview-process nil)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'executable-find) (lambda (_) nil)) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil)) ((symbol-function 'start-process) (lambda (&rest _) (error "start-process should not run"))) ((symbol-function 'message) #'ignore)) diff --git a/tests/test-hugo-config-open-blog-dir-external.el b/tests/test-hugo-config-open-blog-dir-external.el index 0bf689826..05f116e6d 100644 --- a/tests/test-hugo-config-open-blog-dir-external.el +++ b/tests/test-hugo-config-open-blog-dir-external.el @@ -44,7 +44,7 @@ filesystem checks." (cl-letf (((symbol-function 'env-macos-p) (lambda () ,macos-p)) ((symbol-function 'env-windows-p) (lambda () ,windows-p)) ((symbol-function 'file-directory-p) (lambda (_d) t)) - ((symbol-function 'executable-find) (lambda (cmd) cmd)) + ((symbol-function 'executable-find) (lambda (cmd &rest _) cmd)) ((symbol-function 'start-process) (lambda (_name _buf cmd &rest _args) (setq test-hugo--captured-process-cmd cmd)))) @@ -86,7 +86,7 @@ filesystem checks." ((symbol-function 'file-directory-p) (lambda (_d) nil)) ((symbol-function 'make-directory) (lambda (_dir &rest _args) (setq mkdir-called t))) - ((symbol-function 'executable-find) (lambda (cmd) cmd)) + ((symbol-function 'executable-find) (lambda (cmd &rest _) cmd)) ((symbol-function 'start-process) #'ignore)) (cj/hugo-open-blog-dir-external) (should mkdir-called)))) @@ -99,7 +99,7 @@ filesystem checks." ((symbol-function 'file-directory-p) (lambda (_d) t)) ((symbol-function 'make-directory) (lambda (_dir &rest _args) (setq mkdir-called t))) - ((symbol-function 'executable-find) (lambda (cmd) cmd)) + ((symbol-function 'executable-find) (lambda (cmd &rest _) cmd)) ((symbol-function 'start-process) #'ignore)) (cj/hugo-open-blog-dir-external) (should-not mkdir-called)))) @@ -111,7 +111,7 @@ filesystem checks." (cl-letf (((symbol-function 'env-macos-p) (lambda () nil)) ((symbol-function 'env-windows-p) (lambda () nil)) ((symbol-function 'file-directory-p) (lambda (_d) t)) - ((symbol-function 'executable-find) (lambda (_) nil)) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil)) ((symbol-function 'start-process) (lambda (&rest _) (error "start-process should not run")))) (should-error (cj/hugo-open-blog-dir-external) :type 'user-error))) diff --git a/tests/test-init-defer-games.el b/tests/test-init-defer-games.el new file mode 100644 index 000000000..f3ec94de8 --- /dev/null +++ b/tests/test-init-defer-games.el @@ -0,0 +1,46 @@ +;;; test-init-defer-games.el --- games-config Phase 4 deferral -*- lexical-binding: t; -*- + +;;; Commentary: +;; games-config is deferred (load-graph Phase 4): malyon and 2048-game autoload +;; their own commands via package.el, and init.el loads games-config (which only +;; supplies malyon's config) via `with-eval-after-load 'malyon'. These tests +;; guard the command availability and exercise the real autoload-invocation path +;; that M-x uses, which is where an earlier cut regressed ("Autoloading +;; games-config.el failed to define function malyon"). + +;;; Code: + +(require 'ert) +(require 'package) + +(ert-deftest test-init-defer-games-commands-autoload-without-module () + "Normal: the game commands resolve with games-config unloaded. +Dropping the eager require keeps malyon and 2048-game reachable only because the +packages autoload their own commands, so assert that holds." + (package-initialize) + (should-not (featurep 'games-config)) + (should (commandp 'malyon)) + (should (commandp '2048-game))) + +(ert-deftest test-init-defer-games-malyon-loads-and-configures () + "Normal: resolving malyon's autoload yields a real command and applies config. +Reproduces the M-x malyon path via `autoload-do-load': malyon autoloads from its +own package, init.el's `with-eval-after-load 'malyon' loads games-config, and +games-config sets the stories directory. This is the regression guard for the +earlier cut that autoloaded malyon to games-config, where Emacs errored that the +load failed to define malyon." + (package-initialize) + (add-to-list 'load-path (expand-file-name "modules" default-directory)) + (require 'user-constants) + (unless (and (fboundp 'malyon) (autoloadp (symbol-function 'malyon))) + (ert-skip "malyon package not available as an autoload")) + (let ((org-dir "/tmp/games-defer-test/")) + (with-eval-after-load 'malyon (require 'games-config)) ; the init.el wiring + (should-not (featurep 'games-config)) + (should (functionp (autoload-do-load (symbol-function 'malyon) 'malyon))) + (should (commandp 'malyon)) + (should (featurep 'games-config)) + (should (equal malyon-stories-directory "/tmp/games-defer-test/text.games/")))) + +(provide 'test-init-defer-games) +;;; test-init-defer-games.el ends here 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-jumper--register-hygiene.el b/tests/test-jumper--register-hygiene.el new file mode 100644 index 000000000..8fc430ac5 --- /dev/null +++ b/tests/test-jumper--register-hygiene.el @@ -0,0 +1,179 @@ +;;; test-jumper--register-hygiene.el --- Tests for jumper register hygiene -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for three related jumper.el defects from the 2026-06 config audit: +;; +;; 1. Register collisions on removal — removal shifted the vector but never +;; freed the dropped register char, and a later store allocated by +;; `jumper--next-index' (a char a surviving slot might still hold), +;; silently overwriting that slot's marker. Store now allocates the first +;; free char in the live slice; removal clears the freed register. +;; 2. Dead-marker errors — `jumper--with-marker-at' guarded `markerp' but not +;; buffer liveness, so after the buffer holding a location was killed, +;; store/jump signaled wrong-type errors. Dead entries are now skipped. +;; 3. Single-location toggle never toggled back — the `already-there' branch +;; did nothing; it now jumps to the last-location register when set. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'jumper) + +(defvar test-jumper-hyg--orig-registers nil) +(defvar test-jumper-hyg--orig-index nil) + +(defun test-jumper-hyg-setup () + "Reset jumper state and the registers it uses to a clean slate." + (setq test-jumper-hyg--orig-registers jumper--registers) + (setq test-jumper-hyg--orig-index jumper--next-index) + (setq jumper--registers (make-vector jumper-max-locations nil)) + (setq jumper--next-index 0) + (dotimes (i jumper-max-locations) + (set-register (+ ?0 i) nil)) + (set-register jumper--last-location-register nil)) + +(defun test-jumper-hyg-teardown () + "Restore jumper state." + (setq jumper--registers test-jumper-hyg--orig-registers) + (setq jumper--next-index test-jumper-hyg--orig-index)) + +;;; Defect 1 — register collisions on removal + +(ert-deftest test-jumper-hyg-store-after-remove-reuses-freed-register () + "Normal: storing after a removal reuses the freed char, not next-index. +Removing index 0 of [0 1 2] leaves the live slice holding chars 1 and 2; +the next store must take the freed char 0, never 2 (which slot 1 still holds)." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2\nline 3\nline 4") + (goto-char (point-min)) + (jumper--do-store-location) ; ?0 @ line 1 + (forward-line 1) (jumper--do-store-location) ; ?1 @ line 2 + (forward-line 1) (jumper--do-store-location) ; ?2 @ line 3 + (jumper--do-remove-location 0) ; live slice now [?1 ?2] + (forward-line 1) ; line 4 + (let ((reg (jumper--do-store-location))) + (should (= reg ?0)) ; freed char reused + (should (= (aref jumper--registers 2) ?0)) + (should (= jumper--next-index 3)))) + (test-jumper-hyg-teardown))) + +(ert-deftest test-jumper-hyg-store-after-remove-preserves-survivor () + "Normal: the surviving slot's marker is not clobbered by the reused store. +After removing index 0 and storing a new location, jumping to the slot that +holds the old top register must still land on its original line." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2\nline 3\nline 4") + (goto-char (point-min)) + (jumper--do-store-location) ; ?0 @ line 1 + (forward-line 1) (jumper--do-store-location) ; ?1 @ line 2 + (let ((line3 (progn (forward-line 1) (point)))) + (jumper--do-store-location) ; ?2 @ line 3 + (jumper--do-remove-location 0) ; slot1 now holds ?2 @ line3 + (goto-char (point-max)) (jumper--do-store-location) ; reuse ?0 + (goto-char (point-min)) + (jumper--do-jump-to-location 1) ; slot1 = old line-3 marker + (should (= (point) line3)))) + (test-jumper-hyg-teardown))) + +(ert-deftest test-jumper-hyg-remove-clears-freed-register () + "Boundary: removing a location clears its register so the marker is freed." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "test") + (goto-char (point-min)) + (jumper--do-store-location) ; ?0 + (should (get-register ?0)) + (jumper--do-remove-location 0) + (should (null (get-register ?0)))) + (test-jumper-hyg-teardown))) + +;;; Defect 2 — dead-marker entries are skipped, not errored + +(ert-deftest test-jumper-hyg-with-marker-at-dead-buffer-returns-nil () + "Error: a marker whose buffer was killed yields nil, not a wrong-type error." + (test-jumper-hyg-setup) + (let ((buf (generate-new-buffer "jumper-dead-test"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "content") + (goto-char (point-min)) + (jumper--do-store-location)) ; ?0 points into buf + (kill-buffer buf) ; marker now detached + (should (null (jumper--with-marker-at 0 (lambda () 'ran))))) + (when (buffer-live-p buf) (kill-buffer buf)) + (test-jumper-hyg-teardown)))) + +(ert-deftest test-jumper-hyg-location-exists-p-survives-dead-buffer () + "Boundary: location-exists-p does not error when a stored buffer is dead." + (test-jumper-hyg-setup) + (let ((buf (generate-new-buffer "jumper-dead-test-2"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "content") + (goto-char (point-min)) + (jumper--do-store-location)) + (kill-buffer buf) + (should (null (jumper--location-exists-p)))) + (when (buffer-live-p buf) (kill-buffer buf)) + (test-jumper-hyg-teardown)))) + +(ert-deftest test-jumper-hyg-candidates-skip-dead-buffer () + "Boundary: the candidate list omits a location whose buffer was killed." + (test-jumper-hyg-setup) + (let ((buf (generate-new-buffer "jumper-dead-test-3"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "content") + (goto-char (point-min)) + (jumper--do-store-location)) + (kill-buffer buf) + (should (null (jumper--location-candidates)))) + (when (buffer-live-p buf) (kill-buffer buf)) + (test-jumper-hyg-teardown)))) + +;;; Defect 3 — single-location toggle returns to the previous spot + +(ert-deftest test-jumper-hyg-toggle-back-when-last-set () + "Normal: toggling at the only location jumps back to the last-location register. +Jump to the location (which records the prior spot in 'z); toggling again while +sitting on the location returns to that prior spot." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2\nline 3") + (goto-char (point-min)) + (jumper--do-store-location) ; store @ line 1 + (let ((away (point-max))) + (goto-char away) + (jumper--do-jump-to-location nil) ; jump to line 1, 'z := away + (should (= (point) (point-min))) + (let ((result (jumper--do-jump-to-location nil))) ; toggle back + (should (eq result 'jumped-back)) + (should (= (point) away))))) + (test-jumper-hyg-teardown))) + +(ert-deftest test-jumper-hyg-toggle-at-location-no-last-stays () + "Boundary: toggling at the location with no last-location set returns +'already-there and does not move point." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2") + (goto-char (point-min)) + (jumper--do-store-location) + (let ((result (jumper--do-jump-to-location nil))) + (should (eq result 'already-there)) + (should (= (point) (point-min))))) + (test-jumper-hyg-teardown))) + +(provide 'test-jumper--register-hygiene) +;;; test-jumper--register-hygiene.el ends here diff --git a/tests/test-keybindings--jump-open-var.el b/tests/test-keybindings--jump-open-var.el index bd04f4cf1..041f4a7d3 100644 --- a/tests/test-keybindings--jump-open-var.el +++ b/tests/test-keybindings--jump-open-var.el @@ -25,7 +25,7 @@ CAPTURE-VAR is set to the path passed to `find-file', or stays nil if the mock is never called." (declare (indent 1) (debug t)) `(cl-letf (((symbol-function 'find-file) - (lambda (path) (setq ,capture-var path)))) + (lambda (path &rest _) (setq ,capture-var path)))) ,@body)) (defmacro test-keybindings--with-fixture (value &rest body) 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-transport.el b/tests/test-mail-config-transport.el index 2244b6dd2..0240102a2 100644 --- a/tests/test-mail-config-transport.el +++ b/tests/test-mail-config-transport.el @@ -18,7 +18,7 @@ EXECUTABLES is an alist of program name strings to executable paths." (declare (indent 1)) `(let (test-mail-config--warnings) (cl-letf (((symbol-function 'executable-find) - (lambda (program) + (lambda (program &rest _) (cdr (assoc program ,executables)))) ((symbol-function 'display-warning) (lambda (type message &rest _args) diff --git a/tests/test-media-utils.el b/tests/test-media-utils.el index 9384d568f..841b6faf9 100644 --- a/tests/test-media-utils.el +++ b/tests/test-media-utils.el @@ -24,7 +24,7 @@ (ert-deftest test-media-get-available-players-filters-by-executable () "Normal: only players whose :command is on PATH are reported." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (and (member cmd '("mpv" "vlc")) cmd)))) + (lambda (cmd &rest _) (and (member cmd '("mpv" "vlc")) cmd)))) (let ((result (cj/get-available-media-players))) (should (memq 'mpv result)) (should (memq 'vlc result)) @@ -32,7 +32,7 @@ (ert-deftest test-media-get-available-players-none-installed () "Boundary: with nothing on PATH, the list is empty." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-not (cj/get-available-media-players)))) ;; ----------------------------- cj/media-play-it ------------------------------ @@ -41,7 +41,7 @@ "Normal: a player that needs no stream URL gets a plain command, no yt-dlp." (let (captured cj/default-media-player) (setq cj/default-media-player 'mpv) - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/mpv")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/mpv")) ((symbol-function 'start-process-shell-command) (lambda (_n _b cmd) (setq captured cmd) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) @@ -56,7 +56,7 @@ "Normal: a player needing a stream URL wraps the URL in a yt-dlp -g call." (let (captured cj/default-media-player) (setq cj/default-media-player 'vlc) - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/vlc")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/vlc")) ((symbol-function 'start-process-shell-command) (lambda (_n _b cmd) (setq captured cmd) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) @@ -71,7 +71,7 @@ "Error: an unavailable player command signals an error before launching." (let (cj/default-media-player) (setq cj/default-media-player 'mpv) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/media-play-it "https://example.com/v"))))) ;; ------------------------------- cj/yt-dl-it --------------------------------- @@ -79,19 +79,19 @@ (ert-deftest test-media-yt-dl-it-errors-without-yt-dlp () "Error: a missing yt-dlp aborts the download." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (unless (equal cmd "yt-dlp") "/usr/bin/x")))) + (lambda (cmd &rest _) (unless (equal cmd "yt-dlp") "/usr/bin/x")))) (should-error (cj/yt-dl-it "https://example.com/v")))) (ert-deftest test-media-yt-dl-it-errors-without-tsp () "Error: yt-dlp present but tsp missing aborts the download." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (unless (equal cmd "tsp") "/usr/bin/x")))) + (lambda (cmd &rest _) (unless (equal cmd "tsp") "/usr/bin/x")))) (should-error (cj/yt-dl-it "https://example.com/v")))) (ert-deftest test-media-yt-dl-it-builds-tsp-yt-dlp-process () "Normal: with both tools present, the URL is queued via tsp + yt-dlp." (let (captured (videos-dir "/tmp/videos")) - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/x")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) ((symbol-function 'start-process) (lambda (&rest args) (setq captured args) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) diff --git a/tests/test-meta-subr-mock-arity.el b/tests/test-meta-subr-mock-arity.el new file mode 100644 index 000000000..8ee2cb5e0 --- /dev/null +++ b/tests/test-meta-subr-mock-arity.el @@ -0,0 +1,113 @@ +;;; test-meta-subr-mock-arity.el --- Guard against arity-narrow subr mocks -*- lexical-binding: t; -*- + +;;; Commentary: +;; A meta-test: it tests the other tests. Native compilation routes a +;; redefined C primitive (subr) through a trampoline that calls the +;; replacement with the primitive's FULL arity, filling optionals with nil. +;; So a fixed-arity mock that is narrower than the primitive throws +;; `wrong-number-of-arguments' the moment native-comp has compiled that +;; trampoline -- a failure that appears intermittently as the eln-cache fills. +;; +;; The rule this enforces is NOT "never mock a subr" (the suite mocks subrs +;; like `message' and `completing-read' hundreds of times, all fine). It is: +;; a mock of a C primitive must be able to accept the primitive's maximum +;; arity -- in practice, use (lambda (&rest _) ...). This test scans every +;; file under tests/ for `cl-letf' / `setf' / `fset' redefinitions of a +;; `symbol-function', and fails listing any whose replacement is too narrow. +;; +;; It is deterministic: a pure static read of the test sources plus +;; `func-arity', with no dependence on whether native-comp happens to have +;; built the trampoline yet. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'seq) + +(defconst test-meta-subr--test-dir + (expand-file-name "tests" (or (getenv "EMACS_CONFIG_ROOT") default-directory)) + "Directory whose .el files are scanned for subr mocks.") + +(defun test-meta-subr--replacement-arglist (repl) + "Return the formal arglist of REPL, or the symbol `unknown'. +Handles (lambda ARGS ...) and (function (lambda ARGS ...)); returns `variadic' +for forms known to accept any arity (`ignore', `always'), and `unknown' for +anything whose arity can't be read statically (a bare variable, a call)." + (pcase repl + (`(lambda ,args . ,_) args) + (`(function (lambda ,args . ,_)) args) + (`(quote ,(or 'ignore 'always)) 'variadic) + (`(function ,(or 'ignore 'always)) 'variadic) + (_ 'unknown))) + +(defun test-meta-subr--accepts-p (arglist subr-max) + "Non-nil if a lambda with ARGLIST can be called with SUBR-MAX positional args. +ARGLIST may also be `variadic' or `unknown' (both treated as acceptable)." + (cond + ((memq arglist '(variadic unknown)) t) + ((memq '&rest arglist) t) + ((eq subr-max 'many) nil) ; only &rest accepts unbounded arity + ((integerp subr-max) + (>= (length (seq-remove (lambda (s) (memq s '(&optional &rest &key))) + arglist)) + subr-max)) + (t t))) + +(defun test-meta-subr--quoted-symbol (form) + "If FORM is 'SYM or #'SYM, return SYM, else nil." + (pcase form + (`(quote ,(and s (guard (symbolp s)))) s) + (`(function ,(and s (guard (symbolp s)))) s))) + +(defun test-meta-subr--collect (form acc) + "Walk FORM, pushing (SYM . REPLACEMENT) for each symbol-function redefinition. +Covers `cl-letf'/`setf' binding shape ((symbol-function 'SYM) REPL) and +\(fset 'SYM REPL)." + (when (consp form) + ;; (fset 'SYM REPL) + (when (eq (car-safe form) 'fset) + (let ((s (test-meta-subr--quoted-symbol (nth 1 form)))) + (when s (push (cons s (nth 2 form)) acc)))) + ;; binding element ((symbol-function 'SYM) REPL) -- cl-letf, cl-letf*, setf + (when (and (consp (car-safe form)) + (eq (car-safe (car form)) 'symbol-function)) + (let ((s (test-meta-subr--quoted-symbol (nth 1 (car form))))) + (when s (push (cons s (nth 1 form)) acc)))) + (dolist (sub form) (setq acc (test-meta-subr--collect sub acc)))) + acc) + +(defun test-meta-subr--violations () + "Return a list of human-readable violation strings across the test files." + (let ((violations '())) + (dolist (file (directory-files-recursively test-meta-subr--test-dir "\\.el\\'")) + ;; Don't scan this meta-test itself (its examples would self-trip). + (unless (string-suffix-p "test-meta-subr-mock-arity.el" file) + (let ((mocks '())) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (condition-case nil + (while t (setq mocks (test-meta-subr--collect (read (current-buffer)) mocks))) + (error nil))) + (pcase-dolist (`(,sym . ,repl) (nreverse mocks)) + (when (and (fboundp sym) + (condition-case nil (subrp (symbol-function sym)) (error nil))) + (let ((subr-max (cdr (func-arity sym))) + (arglist (test-meta-subr--replacement-arglist repl))) + (unless (test-meta-subr--accepts-p arglist subr-max) + (push (format "%s: mock of subr `%s' (arity max %s) takes %S -- use (&rest _)" + (file-name-nondirectory file) sym subr-max arglist) + violations)))))))) + (nreverse violations))) + +(ert-deftest test-meta-no-arity-narrow-subr-mocks () + "No test mocks a C primitive with a lambda too narrow for its arity. +Such a mock breaks under native-comp's subr trampoline (it calls the mock with +the primitive's full arity). Fix by making the mock variadic: (lambda (&rest _) +...). See this file's commentary." + (let ((violations (test-meta-subr--violations))) + (should (null violations)))) + +(provide 'test-meta-subr-mock-arity) +;;; test-meta-subr-mock-arity.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-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-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-music-config-commands.el b/tests/test-music-config-commands.el index d57e339c4..3c585d0b7 100644 --- a/tests/test-music-config-commands.el +++ b/tests/test-music-config-commands.el @@ -176,9 +176,9 @@ last-played track and starts it." (added-hooks nil) (removed-hooks nil)) (cl-letf (((symbol-function 'add-hook) - (lambda (hook _fn) (push hook added-hooks))) + (lambda (hook _fn &rest _) (push hook added-hooks))) ((symbol-function 'remove-hook) - (lambda (hook _fn) (push hook removed-hooks))) + (lambda (hook _fn &rest _) (push hook removed-hooks))) ((symbol-function 'message) #'ignore)) (cj/music-toggle-consume) (should cj/music-consume-mode) diff --git a/tests/test-music-config-helpers-untested.el b/tests/test-music-config-helpers-untested.el index 4ba0940a5..bfdb2634d 100644 --- a/tests/test-music-config-helpers-untested.el +++ b/tests/test-music-config-helpers-untested.el @@ -113,7 +113,7 @@ test prelude inserts filler with `inhibit-read-only' bound." "Normal: when emms is already a feature, setup does not re-require." (let ((called nil)) (cl-letf (((symbol-function 'featurep) - (lambda (sym) (eq sym 'emms))) + (lambda (sym &rest _) (eq sym 'emms))) ((symbol-function 'require) (lambda (&rest _) (setq called t) t))) (cj/emms--setup)) @@ -123,7 +123,7 @@ test prelude inserts filler with `inhibit-read-only' bound." "Boundary: when emms isn't yet loaded, setup requires it." (let ((required nil)) (cl-letf (((symbol-function 'featurep) - (lambda (sym) (not (eq sym 'emms)))) + (lambda (sym &rest _) (not (eq sym 'emms)))) ((symbol-function 'require) (lambda (feat &rest _) (setq required feat) t))) (cj/emms--setup)) diff --git a/tests/test-music-config-more-commands.el b/tests/test-music-config-more-commands.el index a029a5a33..c351c1f15 100644 --- a/tests/test-music-config-more-commands.el +++ b/tests/test-music-config-more-commands.el @@ -94,7 +94,7 @@ ((symbol-function 'cj/music--playlist-modified-p) (lambda () nil)) ((symbol-function 'find-file-other-window) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (cj/music-playlist-edit)) (delete-file tmp)) (should (equal opened tmp)))) @@ -130,7 +130,7 @@ ((symbol-function 'cj/music--ensure-playlist-buffer) (lambda () buf)) ((symbol-function 'switch-to-buffer) - (lambda (b) (setq switched b))) + (lambda (b &rest _) (setq switched b))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) (cj/music-playlist-show)) diff --git a/tests/test-music-config-playlist-commands.el b/tests/test-music-config-playlist-commands.el index 3d6dfd8b9..891bc700c 100644 --- a/tests/test-music-config-playlist-commands.el +++ b/tests/test-music-config-playlist-commands.el @@ -132,7 +132,7 @@ (cl-letf (((symbol-function 'cj/music--playlist-modified-p) (lambda () nil)) ((symbol-function 'find-file-other-window) - (lambda (p) (setq opened p)))) + (lambda (p &rest _) (setq opened p)))) (cj/music-playlist-edit)) (should (equal opened tmp)) (delete-file tmp)) 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-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 d308fc2b7..671d55ab9 100644 --- a/tests/test-org-capture-config-popup-window.el +++ b/tests/test-org-capture-config-popup-window.el @@ -173,7 +173,7 @@ not whatever frame happens to be selected (the emacsclient -c focus race)." (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))) + (lambda (f &rest _) (setq focused f))) ((symbol-function 'org-capture) (lambda (&rest _) nil))) (cj/quick-capture)) (should (eq focused 'popup-frame)))) @@ -185,7 +185,7 @@ call and still runs the capture (no error)." (captured nil)) (cl-letf (((symbol-function 'cj/org-capture--popup-frame) (lambda () nil)) ((symbol-function 'select-frame-set-input-focus) - (lambda (f) (setq focused f))) + (lambda (f &rest _) (setq focused f))) ((symbol-function 'org-capture) (lambda (&rest _) (setq captured t)))) (cj/quick-capture)) (should (eq focused 'unset)) diff --git a/tests/test-org-drill-config-commands.el b/tests/test-org-drill-config-commands.el index c35bd6cd4..38f6b66e3 100644 --- a/tests/test-org-drill-config-commands.el +++ b/tests/test-org-drill-config-commands.el @@ -38,7 +38,7 @@ (let (opened (drilled 0)) (cl-letf (((symbol-function 'cj/--drill-pick-file) (lambda (_dir) "/decks/german.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'org-drill) (lambda (&rest _) (cl-incf drilled)))) (cj/drill-edit)) @@ -54,7 +54,7 @@ (with-temp-file (expand-file-name "latin.org" tmp)) (cl-letf (((symbol-function 'read-directory-name) (lambda (&rest _) tmp)) ((symbol-function 'completing-read) (lambda (&rest _) "latin.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f)))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f)))) (cj/drill-edit t)) (should (equal (expand-file-name "latin.org" tmp) opened))) (delete-directory tmp t)))) @@ -85,7 +85,7 @@ and validation)." ((symbol-function 'directory-files) (lambda (&rest _) '("/WRONG/raw.org"))) ((symbol-function 'call-interactively) - (lambda (fn) + (lambda (fn &rest _) (setq called-fn fn seen-targets org-refile-targets)))) (cj/drill-refile)) @@ -101,7 +101,7 @@ survives the call instead of being permanently replaced." (let ((drill-dir "/tmp/cj-drill/") (org-refile-targets '((sentinel :maxlevel . 9)))) (cl-letf (((symbol-function 'cj/--drill-files-or-error) (lambda (_dir) '("a.org"))) - ((symbol-function 'call-interactively) (lambda (_fn) nil))) + ((symbol-function 'call-interactively) (lambda (_fn &rest _) nil))) (cj/drill-refile)) (should (equal org-refile-targets '((sentinel :maxlevel . 9)))))) @@ -112,7 +112,7 @@ the shared validated helper, instead of a low-level error, and never reaches (let ((drill-dir (expand-file-name "cj-drill-nonexistent-XYZ/" temporary-file-directory)) (called nil)) - (cl-letf (((symbol-function 'call-interactively) (lambda (_fn) (setq called t)))) + (cl-letf (((symbol-function 'call-interactively) (lambda (_fn &rest _) (setq called t)))) (should-error (cj/drill-refile) :type 'user-error)) (should-not called))) diff --git a/tests/test-org-drill-config.el b/tests/test-org-drill-config.el index d3057de2a..9dffa0bca 100644 --- a/tests/test-org-drill-config.el +++ b/tests/test-org-drill-config.el @@ -118,7 +118,7 @@ (let (opened (drilled 0)) (cl-letf (((symbol-function 'cj/--drill-pick-file) (lambda (_dir) "/decks/french.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'org-drill) (lambda (&rest _) (cl-incf drilled)))) (cj/drill-start)) (should (equal "/decks/french.org" opened)) @@ -131,7 +131,7 @@ (let (opened) (cl-letf (((symbol-function 'read-directory-name) (lambda (&rest _) dir)) ((symbol-function 'completing-read) (lambda (&rest _) "latin.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'org-drill) #'ignore)) (cj/drill-start t)) (should (equal (expand-file-name "latin.org" dir) opened))))) diff --git a/tests/test-org-noter-config-commands.el b/tests/test-org-noter-config-commands.el index 8860af06e..70c78645c 100644 --- a/tests/test-org-noter-config-commands.el +++ b/tests/test-org-noter-config-commands.el @@ -115,7 +115,7 @@ ((symbol-function 'org-id-uuid) (lambda () "00000000-0000-0000-0000-000000000000")) ((symbol-function 'find-file-noselect) - (lambda (f) (get-buffer-create (concat "*test-" f "*"))))) + (lambda (f &rest _) (get-buffer-create (concat "*test-" f "*"))))) (let ((path (cj/org-noter--create-notes-file))) (should (file-exists-p path)) (with-temp-buffer @@ -186,7 +186,7 @@ ((symbol-function 'org-noter--get-doc-window) (lambda () 'doc-win)) ((symbol-function 'select-window) - (lambda (w) (setq selected w)))) + (lambda (w &rest _) (setq selected w)))) (cj/org-noter-start)) (should (eq selected 'doc-win)))) @@ -232,7 +232,7 @@ ((symbol-function 'org-noter--get-doc-window) (lambda () 'doc-win)) ((symbol-function 'select-window) - (lambda (w) (setq selected w))) + (lambda (w &rest _) (setq selected w))) ((symbol-function 'org-noter-insert-note) (lambda () (setq inserted t)))) (cj/org-noter-insert-note-dwim)) diff --git a/tests/test-org-refile-config-commands.el b/tests/test-org-refile-config-commands.el index 9bdd33647..2e99e9152 100644 --- a/tests/test-org-refile-config-commands.el +++ b/tests/test-org-refile-config-commands.el @@ -54,7 +54,7 @@ (with-temp-buffer (setq buffer-file-name "/tmp/notes.org") (cl-letf (((symbol-function 'call-interactively) - (lambda (_fn) + (lambda (_fn &rest _) (setq seen-targets org-refile-targets))) ((symbol-function 'save-buffer) #'ignore)) (cj/org-refile-in-file)) @@ -73,7 +73,7 @@ (setq buffer-file-name "/tmp/notes.org") (cl-letf (((symbol-function 'call-interactively) #'ignore) ((symbol-function 'save-buffer) - (lambda () (setq saved t)))) + (lambda (&rest _) (setq saved t)))) (cj/org-refile-in-file)) (setq buffer-file-name nil)) (should saved))) diff --git a/tests/test-org-reveal-config-header-template.el b/tests/test-org-reveal-config-header-template.el index df1db9e77..9bda10db7 100644 --- a/tests/test-org-reveal-config-header-template.el +++ b/tests/test-org-reveal-config-header-template.el @@ -24,9 +24,9 @@ ;; Helper to call template with deterministic date and author (defun test-reveal--header (title) "Call cj/--reveal-header-template with TITLE, mocking time and user." - (cl-letf (((symbol-function 'user-full-name) (lambda () "Test Author")) + (cl-letf (((symbol-function 'user-full-name) (lambda (&rest _) "Test Author")) ((symbol-function 'format-time-string) - (lambda (_fmt) "2026-02-14"))) + (lambda (_fmt &rest _) "2026-02-14"))) (cj/--reveal-header-template title))) ;;; Normal Cases diff --git a/tests/test-org-webclipper-commands.el b/tests/test-org-webclipper-commands.el index be7fc38cf..fb693192f 100644 --- a/tests/test-org-webclipper-commands.el +++ b/tests/test-org-webclipper-commands.el @@ -120,7 +120,7 @@ that registers the webclip entry. Providing `'org-protocol' fires the block." (let ((cj/--webclip-url "https://example.com") (cj/--webclip-title "Title")) (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (let ((err (should-error (cj/org-protocol-webclip-handler) :type 'user-error))) (should (string-match-p "pandoc" (cadr err))))))) @@ -130,7 +130,7 @@ that registers the webclip entry. Providing `'org-protocol' fires the block." (let ((cj/--webclip-url "https://example.com") (cj/--webclip-title "Title")) (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'executable-find) (lambda (_) "/usr/bin/pandoc")) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/pandoc")) ((symbol-function 'org-web-tools--url-as-readable-org) (lambda (_) "* Page Title\n** Sub heading\nBody.\n")) ((symbol-function 'message) #'ignore)) @@ -142,7 +142,7 @@ that registers the webclip entry. Providing `'org-protocol' fires the block." (let ((cj/--webclip-url "https://example.com") (cj/--webclip-title "Title")) (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'executable-find) (lambda (_) "/usr/bin/pandoc")) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/pandoc")) ((symbol-function 'org-web-tools--url-as-readable-org) (lambda (_) "* Page Title\n** Sub heading\nBody.\n")) ((symbol-function 'message) #'ignore)) diff --git a/tests/test-prog-c-mode-settings.el b/tests/test-prog-c-mode-settings.el index 37a77a213..33c503377 100644 --- a/tests/test-prog-c-mode-settings.el +++ b/tests/test-prog-c-mode-settings.el @@ -18,7 +18,7 @@ (cl-letf (((symbol-function 'auto-fill-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))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/c-mode-settings)) (should (eq indent-tabs-mode nil)) (should (= c-basic-offset 4)) @@ -33,7 +33,7 @@ (cl-letf (((symbol-function 'auto-fill-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"))) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/clangd"))) (cj/c-mode-settings))) (should (= lsp-calls 1)))) @@ -44,7 +44,7 @@ (cl-letf (((symbol-function 'auto-fill-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))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/c-mode-settings))) (should (zerop lsp-calls)))) 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-file-respecting-split.el b/tests/test-prog-general--find-file-respecting-split.el index 6d45c51c0..821cc79d6 100644 --- a/tests/test-prog-general--find-file-respecting-split.el +++ b/tests/test-prog-general--find-file-respecting-split.el @@ -23,9 +23,9 @@ (delete-other-windows) (let (current-arg other-called) (cl-letf (((symbol-function 'find-file) - (lambda (f) (setq current-arg f))) + (lambda (f &rest _) (setq current-arg f))) ((symbol-function 'find-file-other-window) - (lambda (_f) (setq other-called t)))) + (lambda (_f &rest _) (setq other-called t)))) (cj/--find-file-respecting-split "/tmp/proj/todo.org")) (should (equal current-arg "/tmp/proj/todo.org")) (should-not other-called)))) @@ -37,9 +37,9 @@ (split-window-right) (let (other-arg current-called) (cl-letf (((symbol-function 'find-file-other-window) - (lambda (f) (setq other-arg f))) + (lambda (f &rest _) (setq other-arg f))) ((symbol-function 'find-file) - (lambda (_f) (setq current-called t)))) + (lambda (_f &rest _) (setq current-called t)))) (cj/--find-file-respecting-split "/tmp/proj/todo.org")) (should (equal other-arg "/tmp/proj/todo.org")) (should-not current-called)))) @@ -52,9 +52,9 @@ (split-window-below) (let (other-called current-called) (cl-letf (((symbol-function 'find-file-other-window) - (lambda (_f) (setq other-called t))) + (lambda (_f &rest _) (setq other-called t))) ((symbol-function 'find-file) - (lambda (_f) (setq current-called t)))) + (lambda (_f &rest _) (setq current-called t)))) (cj/--find-file-respecting-split "/tmp/proj/todo.org")) (should other-called) (should-not current-called)))) 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-general-open-project-daily-prep.el b/tests/test-prog-general-open-project-daily-prep.el index d9c78ff0e..5bc4d7d27 100644 --- a/tests/test-prog-general-open-project-daily-prep.el +++ b/tests/test-prog-general-open-project-daily-prep.el @@ -40,7 +40,7 @@ (unwind-protect (progn (cl-letf (((symbol-function 'projectile-project-root) (lambda () root)) - ((symbol-function 'find-file-other-window) (lambda (f) (setq opened f)))) + ((symbol-function 'find-file-other-window) (lambda (f &rest _) (setq opened f)))) (setq result (cj/open-project-daily-prep))) (should-not opened) (should (string-match-p "No daily-prep.org" result))) @@ -50,7 +50,7 @@ "Error: outside a Projectile project, do not open; report it." (let (opened result) (cl-letf (((symbol-function 'projectile-project-root) (lambda () nil)) - ((symbol-function 'find-file-other-window) (lambda (f) (setq opened f)))) + ((symbol-function 'find-file-other-window) (lambda (f &rest _) (setq opened f)))) (setq result (cj/open-project-daily-prep))) (should-not opened) (should (string-match-p "Not in a Projectile project" result)))) diff --git a/tests/test-prog-go-commands.el b/tests/test-prog-go-commands.el index a2fc0625f..6e6998348 100644 --- a/tests/test-prog-go-commands.el +++ b/tests/test-prog-go-commands.el @@ -54,7 +54,7 @@ ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) - (lambda (path) (when (equal path gopls-path) "/usr/bin/gopls")))) + (lambda (path &rest _) (when (equal path gopls-path) "/usr/bin/gopls")))) (cj/go-setup)) (should started)))) @@ -66,7 +66,7 @@ ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/go-setup)) (should-not started)))) @@ -104,7 +104,7 @@ "Normal: with delve on PATH, `gud-gdb' is called with `dlv debug'." (let (started) (cl-letf (((symbol-function 'executable-find) - (lambda (path) (when (equal path dlv-path) "/usr/bin/dlv"))) + (lambda (path &rest _) (when (equal path dlv-path) "/usr/bin/dlv"))) ((symbol-function 'file-executable-p) (lambda (_) nil)) ((symbol-function 'gud-gdb) (lambda (cmd &rest _) (setq started cmd)))) @@ -117,7 +117,7 @@ "Error: delve missing -> message + no gud-gdb call." (let ((started nil) (msg nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil)) ((symbol-function 'file-executable-p) (lambda (_) nil)) ((symbol-function 'gud-gdb) (lambda (&rest _) (setq started t))) diff --git a/tests/test-prog-json--json-format-buffer.el b/tests/test-prog-json--json-format-buffer.el index 70d7e98bb..c6297a404 100644 --- a/tests/test-prog-json--json-format-buffer.el +++ b/tests/test-prog-json--json-format-buffer.el @@ -16,7 +16,7 @@ (ert-deftest test-prog-json--json-format-buffer-invokes-jq-argv () "Normal: with jq present, the formatter calls jq via argv, no shell." (let (program args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/jq")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/jq")) ((symbol-function 'call-process-region) (lambda (_start _end prog &rest rest) (setq program prog @@ -31,7 +31,7 @@ (ert-deftest test-prog-json--json-format-buffer-no-clobber-on-failure () "Error: a non-zero jq exit leaves the buffer untouched and signals an error." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/jq")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/jq")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "jq: parse error")) @@ -112,7 +112,7 @@ (ert-deftest test-prog-json--json-format-buffer-fallback-formats-without-jq () "Falls back to built-in formatter when jq is not found." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (with-temp-buffer (insert "{\"b\":1,\"a\":2}") (cj/json-format-buffer) diff --git a/tests/test-prog-python-commands.el b/tests/test-prog-python-commands.el index 443e7d175..55aa502f7 100644 --- a/tests/test-prog-python-commands.el +++ b/tests/test-prog-python-commands.el @@ -64,7 +64,7 @@ "Normal: with mypy on PATH, `compile' gets the builder's command." (let ((mypy-path "mypy") compiled) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/mypy")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/mypy")) ((symbol-function 'compile) (lambda (cmd &rest _) (setq compiled cmd)))) (with-temp-buffer (setq buffer-file-name "/home/me/foo.py") @@ -76,7 +76,7 @@ "Boundary: no file -> the command targets `default-directory'." (let ((mypy-path "mypy") compiled) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/mypy")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/mypy")) ((symbol-function 'compile) (lambda (cmd &rest _) (setq compiled cmd)))) (with-temp-buffer (setq-local default-directory "/home/me/proj/") @@ -88,7 +88,7 @@ (let ((mypy-path "mypy") (compiled nil) (messaged nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) nil)) ((symbol-function 'compile) (lambda (&rest _) (setq compiled t))) ((symbol-function 'message) (lambda (fmt &rest args) (setq messaged (apply #'format fmt args))))) diff --git a/tests/test-prog-python-setup.el b/tests/test-prog-python-setup.el index 0b56f8cc9..368097c9e 100644 --- a/tests/test-prog-python-setup.el +++ b/tests/test-prog-python-setup.el @@ -71,7 +71,7 @@ electric-pair-local-mode all get called once." ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) - (lambda (path) (when (equal path pyright-path) + (lambda (path &rest _) (when (equal path pyright-path) "/usr/bin/pyright")))) (cj/python-setup)) (should started)))) @@ -86,7 +86,7 @@ electric-pair-local-mode all get called once." ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/python-setup)) (should-not started)))) diff --git a/tests/test-prog-webdev-format.el b/tests/test-prog-webdev-format.el index 694f9e968..cb5da406c 100644 --- a/tests/test-prog-webdev-format.el +++ b/tests/test-prog-webdev-format.el @@ -46,7 +46,7 @@ (ert-deftest test-prog-webdev-format-buffer-runs-prettier-on-the-file () "Normal: with prettier on PATH, the argv targets `buffer-file-name'." (let (program args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end prog &rest rest) ;; rest = (DELETE BUFFER DISPLAY &rest ARGS) @@ -64,7 +64,7 @@ (ert-deftest test-prog-webdev-format-buffer-falls-back-to-file-ts () "Boundary: a buffer with no file uses the \"file.ts\" filename hint." (let (args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog &rest rest) (setq args (nthcdr 3 rest)) @@ -77,7 +77,7 @@ (ert-deftest test-prog-webdev-format-buffer-clamps-point-to-point-max () "Boundary: after a format that shrinks the buffer, point clamps to point-max." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) ;; Simulate prettier writing a shorter result to the output buffer. @@ -91,7 +91,7 @@ (ert-deftest test-prog-webdev-format-buffer-replaces-on-success () "Normal: a zero exit replaces the buffer with the formatter's output." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "const x = 1;\n")) @@ -103,7 +103,7 @@ (ert-deftest test-prog-webdev-format-buffer-no-clobber-on-failure () "Error: a non-zero exit leaves the buffer untouched and signals an error." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "[error] syntax error")) @@ -117,7 +117,7 @@ (ert-deftest test-prog-webdev-format-buffer-errors-without-prettier () "Error: prettier missing -> `user-error', nothing shells out." (let ((ran nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) nil)) ((symbol-function 'call-process-region) (lambda (&rest _) (setq ran t) 0))) (with-temp-buffer diff --git a/tests/test-prog-webdev-setup.el b/tests/test-prog-webdev-setup.el index 45310f237..906a54151 100644 --- a/tests/test-prog-webdev-setup.el +++ b/tests/test-prog-webdev-setup.el @@ -67,7 +67,7 @@ electric-pair-local-mode all get called." ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) - (lambda (path) (when (equal path ts-language-server-path) + (lambda (path &rest _) (when (equal path ts-language-server-path) "/usr/bin/typescript-language-server")))) (cj/webdev-setup)) (should started)))) @@ -82,7 +82,7 @@ electric-pair-local-mode all get called." ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/webdev-setup)) (should-not started)))) diff --git a/tests/test-prog-yaml--yaml-format-buffer.el b/tests/test-prog-yaml--yaml-format-buffer.el index 28ad351f9..aae3199ce 100644 --- a/tests/test-prog-yaml--yaml-format-buffer.el +++ b/tests/test-prog-yaml--yaml-format-buffer.el @@ -14,7 +14,7 @@ (ert-deftest test-prog-yaml--yaml-format-buffer-invokes-prettier-argv () "Normal: with prettier present, the formatter calls it via argv, no shell." (let (program args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end prog &rest rest) (setq program prog @@ -29,7 +29,7 @@ (ert-deftest test-prog-yaml--yaml-format-buffer-no-clobber-on-failure () "Error: a non-zero prettier exit leaves the buffer untouched and errors." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "[error] bad yaml")) @@ -98,7 +98,7 @@ (ert-deftest test-prog-yaml--yaml-format-buffer-error-no-prettier () "Signals user-error when prettier is not found." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (with-temp-buffer (insert "key: value\n") (should-error (cj/yaml-format-buffer) :type 'user-error)))) 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-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-slack-config-commands.el b/tests/test-slack-config-commands.el index 8944662ef..21cbb3e5a 100644 --- a/tests/test-slack-config-commands.el +++ b/tests/test-slack-config-commands.el @@ -194,7 +194,7 @@ ((symbol-function 'slack-buffer-update-mark-request) (lambda (_buf ts) (setq marked ts))) ((symbol-function 'bury-buffer) - (lambda () (setq buried t)))) + (lambda (&rest _) (setq buried t)))) (cj/slack-mark-read-and-bury)) (should (equal marked "1234.5678")) (should buried))) @@ -207,7 +207,7 @@ (cl-letf (((symbol-function 'slack-buffer-update-mark-request) (lambda (&rest _) (setq marked t))) ((symbol-function 'bury-buffer) - (lambda () (setq buried t)))) + (lambda (&rest _) (setq buried t)))) (cj/slack-mark-read-and-bury)) (should-not marked) (should buried))) diff --git a/tests/test-system-commands-resolve-and-run.el b/tests/test-system-commands-resolve-and-run.el index 2c9d98d0c..af2288fd9 100644 --- a/tests/test-system-commands-resolve-and-run.el +++ b/tests/test-system-commands-resolve-and-run.el @@ -118,19 +118,19 @@ does not run the command." (ert-deftest test-system-cmd-service-available-true-on-zero-exit () "Normal: service is available when systemctl exists and `cat' exits 0." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/systemctl")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/systemctl")) ((symbol-function 'call-process) (lambda (&rest _) 0))) (should (cj/system-cmd--emacs-service-available-p)))) (ert-deftest test-system-cmd-service-available-false-on-nonzero-exit () "Boundary: a nonzero exit (no such unit) means not available." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/systemctl")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/systemctl")) ((symbol-function 'call-process) (lambda (&rest _) 1))) (should-not (cj/system-cmd--emacs-service-available-p)))) (ert-deftest test-system-cmd-service-available-false-when-systemctl-absent () "Error: with no systemctl on PATH the service can't be available." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) nil)) ((symbol-function 'call-process) (lambda (&rest _) (error "must not shell out without systemctl")))) (should-not (cj/system-cmd--emacs-service-available-p)))) @@ -220,7 +220,7 @@ kill-emacs directly (the service owns the daemon lifecycle)." (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "Lock Screen")) ((symbol-function 'call-interactively) - (lambda (cmd) (setq called cmd)))) + (lambda (cmd &rest _) (setq called cmd)))) (cj/system-command-menu)) (should (eq called 'cj/system-cmd-lock)))) diff --git a/tests/test-system-defaults-functions.el b/tests/test-system-defaults-functions.el index a5210be01..2562ff6aa 100644 --- a/tests/test-system-defaults-functions.el +++ b/tests/test-system-defaults-functions.el @@ -79,20 +79,6 @@ (should (eq (cj/disabled) nil)) (should (commandp #'cj/disabled))) -;;; cj/minibuffer-setup-hook / cj/minibuffer-exit-hook - -(ert-deftest test-system-defaults-minibuffer-setup-inflates-gc-threshold () - "Normal: entering the minibuffer raises `gc-cons-threshold' to most-positive-fixnum." - (let ((gc-cons-threshold 800000)) - (cj/minibuffer-setup-hook) - (should (= gc-cons-threshold most-positive-fixnum)))) - -(ert-deftest test-system-defaults-minibuffer-exit-restores-gc-threshold () - "Normal: leaving the minibuffer restores `gc-cons-threshold' to 800000." - (let ((gc-cons-threshold most-positive-fixnum)) - (cj/minibuffer-exit-hook) - (should (= gc-cons-threshold 800000)))) - ;;; unpropertize-kill-ring (ert-deftest test-system-defaults-unpropertize-kill-ring-strips-properties () diff --git a/tests/test-system-defaults.el b/tests/test-system-defaults.el index 928124f56..f653e1fbb 100644 --- a/tests/test-system-defaults.el +++ b/tests/test-system-defaults.el @@ -63,19 +63,6 @@ test clears it first to capture the path derived from the sandbox." (expand-file-name dir))) (should (string-suffix-p "backups" (directory-file-name dir))))))) -;;; minibuffer GC hooks - -(ert-deftest test-system-defaults-minibuffer-gc-hooks-registered () - "Normal: the minibuffer GC raise/restore hooks are installed. -Their bodies are tested in test-system-defaults-functions.el; this asserts -they are actually wired onto the minibuffer hooks." - (test-system-defaults--with-load-environment - (let ((minibuffer-setup-hook nil) - (minibuffer-exit-hook nil)) - (test-system-defaults--load) - (should (memq 'cj/minibuffer-setup-hook minibuffer-setup-hook)) - (should (memq 'cj/minibuffer-exit-hook minibuffer-exit-hook))))) - ;;; Customize-save warning (ert-deftest test-system-defaults-customize-save-warns-once () 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-term-tmux-history.el b/tests/test-term-tmux-history.el index 51e9725c4..4ad7fb79d 100644 --- a/tests/test-term-tmux-history.el +++ b/tests/test-term-tmux-history.el @@ -75,7 +75,7 @@ RESPONSES is an alist of (ARGS EXIT-CODE OUTPUT)." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/8\t%8\n") @@ -106,7 +106,7 @@ the terminal's frame slot rather than splitting or popping a new window." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/8\t%8\n") @@ -194,7 +194,7 @@ ghostel-mode terminal." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/1\t%1\n/dev/pts/8\t%8\n")) @@ -210,7 +210,7 @@ ghostel-mode terminal." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/8\t%8\n")) @@ -226,7 +226,7 @@ ghostel-mode terminal." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/1\t%1\n")) @@ -242,7 +242,7 @@ ghostel-mode terminal." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 1 "no server running")) @@ -273,7 +273,7 @@ puts it at column 0 so it runs up the left." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8")) + (lambda (_process &rest _) "/dev/pts/8")) ((symbol-function 'ghostel-send-string) (lambda (s) (push s sent))) ((symbol-function 'ghostel-copy-mode) @@ -301,7 +301,7 @@ scrolling, parity with the tmux branch's trailing C-a." (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8")) + (lambda (_process &rest _) "/dev/pts/8")) ((symbol-function 'ghostel-send-string) (lambda (s) (push s sent))) ((symbol-function 'ghostel-copy-mode) @@ -336,14 +336,15 @@ instead of being forwarded to the terminal program." (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "C-M-<left>") 'ghostel--send-event))) -(ert-deftest test-term-f10-music-and-shutdown-in-keymap-exceptions () - "Regression: F10 (music playlist toggle) and C-F10 (server shutdown) are in -`ghostel-keymap-exceptions' so they reach Emacs from inside a ghostel buffer -instead of being forwarded to the terminal program. Both are global bindings, -so dropping them from the semi-char map lets the lookup fall through to the -global map." - (dolist (key '("<f10>" "C-<f10>")) - (should (member key ghostel-keymap-exceptions))) +(ert-deftest test-term-f10-music-in-keymap-exceptions () + "Regression: F10 (music playlist toggle) is in `ghostel-keymap-exceptions' +so it reaches Emacs from inside a ghostel buffer instead of being forwarded +to the terminal program. It is a global binding, so dropping it from the +semi-char map lets the lookup fall through to the global map. Server +shutdown moved off C-F10 to C-x C, which is deliberately NOT an exception +(C-x C stays forwarding to the terminal program inside an agent buffer)." + (should (member "<f10>" ghostel-keymap-exceptions)) + (should-not (member "C-<f10>" ghostel-keymap-exceptions)) (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "<f10>") 'ghostel--send-event))) 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-transcription-process-and-sentinel.el b/tests/test-transcription-process-and-sentinel.el index 330a0260b..90b56f0a5 100644 --- a/tests/test-transcription-process-and-sentinel.el +++ b/tests/test-transcription-process-and-sentinel.el @@ -26,7 +26,7 @@ (let (msg) (cl-letf (((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args)))) - ((symbol-function 'getenv) (lambda (_) nil))) + ((symbol-function 'getenv) (lambda (_ &rest _) nil))) (cj/--notify "Transcription" "started")) (should (equal msg "Transcription: started")))) @@ -36,7 +36,7 @@ the title, body, and urgency." (let (notify-kwargs) (cl-letf (((symbol-function 'message) #'ignore) ((symbol-function 'getenv) - (lambda (var) (and (equal var "DISPLAY") ":0"))) + (lambda (var &rest _) (and (equal var "DISPLAY") ":0"))) ((symbol-function 'notifications-notify) (lambda (&rest kwargs) (setq notify-kwargs kwargs)))) (cj/--notify "Transcription" "done" 'critical)) diff --git a/tests/test-transcription-status-and-commands.el b/tests/test-transcription-status-and-commands.el index 7c796de0e..af7255cdc 100644 --- a/tests/test-transcription-status-and-commands.el +++ b/tests/test-transcription-status-and-commands.el @@ -138,7 +138,7 @@ (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) ((symbol-function 'kill-process) - (lambda (p) (setq killed p))) + (lambda (p &rest _) (setq killed p))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) diff --git a/tests/test-ui-buffer-status-colors.el b/tests/test-ui-buffer-status-colors.el deleted file mode 100644 index 06e466b85..000000000 --- a/tests/test-ui-buffer-status-colors.el +++ /dev/null @@ -1,98 +0,0 @@ -;;; test-ui-buffer-status-colors.el --- Tests for buffer-status faces -*- lexical-binding: t; -*- - -;;; Commentary: -;; The buffer-status state classifier (`cj/buffer-status-state'), the state->face -;; map (`cj/buffer-status-faces'), and the resolver (`cj/buffer-status-color') -;; drive both the cursor color and the modeline buffer-name color, kept in sync. -;; Theme faces (error / warning / success) replace the old hard-coded hexes so -;; the colors follow whatever theme is loaded. - -;;; Code: - -(require 'ert) -(require 'user-constants) -(require 'ui-config) -(require 'modeline-config) - -;;; State -> face map - -(ert-deftest test-buffer-status-faces-has-all-states () - "Normal: every buffer state is mapped to a face." - (dolist (state '(read-only overwrite modified unmodified)) - (should (alist-get state cj/buffer-status-faces)))) - -(ert-deftest test-buffer-status-faces-values-are-real-faces () - "Normal: every mapped value is an existing face." - (dolist (entry cj/buffer-status-faces) - (should (facep (cdr entry))))) - -(ert-deftest test-buffer-status-faces-mapping () - "Normal: read-only->error, overwrite/modified->warning, unmodified->success." - (should (eq (alist-get 'read-only cj/buffer-status-faces) 'error)) - (should (eq (alist-get 'overwrite cj/buffer-status-faces) 'warning)) - (should (eq (alist-get 'modified cj/buffer-status-faces) 'warning)) - (should (eq (alist-get 'unmodified cj/buffer-status-faces) 'success))) - -;;; State classifier (the shared function, exercised directly) - -(ert-deftest test-buffer-status-state-read-only () - "Normal: a read-only buffer reports `read-only'." - (with-temp-buffer - (setq buffer-read-only t) - (should (eq (cj/buffer-status-state) 'read-only)))) - -(ert-deftest test-buffer-status-state-overwrite-wins-over-modified () - "Boundary: overwrite-mode takes priority over the modified state." - (with-temp-buffer - (insert "x") - (overwrite-mode 1) - (should (eq (cj/buffer-status-state) 'overwrite)))) - -(ert-deftest test-buffer-status-state-modified () - "Normal: a writeable buffer with unsaved changes reports `modified'." - (with-temp-buffer - (insert "x") - (should (eq (cj/buffer-status-state) 'modified)))) - -(ert-deftest test-buffer-status-state-unmodified () - "Normal: a clean writeable buffer reports `unmodified'." - (with-temp-buffer - (set-buffer-modified-p nil) - (should (eq (cj/buffer-status-state) 'unmodified)))) - -(ert-deftest test-buffer-status-state-read-only-wins-over-modified () - "Boundary: read-only takes priority over modified." - (with-temp-buffer - (insert "x") - (set-buffer-modified-p t) - (setq buffer-read-only t) - (should (eq (cj/buffer-status-state) 'read-only)))) - -;;; Resolver - -(ert-deftest test-buffer-status-color-resolves-through-the-face () - "Normal: the color is the mapped face's foreground." - (let ((orig (face-attribute 'error :foreground nil t))) - (unwind-protect - (progn - (set-face-foreground 'error "#abcdef") - (should (equal (cj/buffer-status-color 'read-only) "#abcdef"))) - (when (stringp orig) (set-face-foreground 'error orig))))) - -(ert-deftest test-buffer-status-color-nil-for-unknown-state () - "Error: an unknown state has no face, so no color." - (should-not (cj/buffer-status-color 'nonexistent))) - -;;; Modeline integration - -(ert-deftest test-modeline-buffer-name-variable-exists () - "Normal: the modeline buffer-name construct is defined." - (should (boundp 'cj/modeline-buffer-name))) - -(ert-deftest test-modeline-buffer-name-is-mode-line-construct () - "Normal: it is an :eval mode-line construct." - (should (listp cj/modeline-buffer-name)) - (should (eq (car cj/modeline-buffer-name) :eval))) - -(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 99cfc4b9d..000000000 --- a/tests/test-ui-config--buffer-cursor-state.el +++ /dev/null @@ -1,74 +0,0 @@ -;;; test-ui-config--buffer-cursor-state.el --- Tests for cursor-state classification -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/buffer-status-state' picks the buffer-state symbol the modeline -;; buffer-name indicator maps to a face via `cj/buffer-status-color'. 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-status-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-status-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-status-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-status-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-status-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-status-state) 'read-only))) - (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-config-transparency-and-cursor.el b/tests/test-ui-config-transparency-and-cursor.el index b01fa2b71..13906773b 100644 --- a/tests/test-ui-config-transparency-and-cursor.el +++ b/tests/test-ui-config-transparency-and-cursor.el @@ -23,7 +23,7 @@ (cj/transparency-level 70) (default-frame-alist nil) (applied nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (_frame param value) (when (eq param 'alpha) (setq applied value))))) @@ -37,7 +37,7 @@ (cj/transparency-level 50) (default-frame-alist '((alpha . (50 . 50)))) (applied nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (_frame param value) (when (eq param 'alpha) (setq applied value))))) @@ -52,7 +52,7 @@ the default-frame-alist so a future graphical frame would pick it up." (cj/transparency-level 60) (default-frame-alist nil) (set-called nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () nil)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) nil)) ((symbol-function 'set-frame-parameter) (lambda (&rest _) (setq set-called t)))) (cj/apply-transparency)) @@ -66,7 +66,7 @@ surfaced via `message'; the default-alist update still happens." (cj/transparency-level 60) (default-frame-alist nil) (msg nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (&rest _) (error "boom"))) ((symbol-function 'message) @@ -83,7 +83,7 @@ surfaced via `message'; the default-alist update still happens." (cj/transparency-level 80) (default-frame-alist nil) (applied nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (_frame param value) (when (eq param 'alpha) (setq applied value)))) @@ -97,7 +97,7 @@ surfaced via `message'; the default-alist update still happens." (let ((cj/enable-transparency t) (cj/transparency-level 90) (default-frame-alist nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) #'ignore) ((symbol-function 'message) #'ignore)) (cj/toggle-transparency) 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 f6981a36a..35ed7a020 100644 --- a/tests/test-ui-navigation-split-follow-undo-kill.el +++ b/tests/test-ui-navigation-split-follow-undo-kill.el @@ -70,7 +70,7 @@ non-visited entry, not the second." (setq buffer-file-name "/tmp/alive.txt")) b)))) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (unwind-protect (cj/undo-kill-buffer 1) (when (get-buffer "*test-alive*") (kill-buffer "*test-alive*")))) @@ -93,7 +93,7 @@ currently-open most-recent file was never skipped." (setq buffer-file-name "/tmp/alive.txt")) b)))) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (unwind-protect (cj/undo-kill-buffer 1) (when (get-buffer "*test-alive*") (kill-buffer "*test-alive*")))) @@ -108,7 +108,7 @@ currently-open most-recent file was never skipped." ((symbol-function 'recentf-mode) (lambda (&rest _) t)) ((symbol-function 'buffer-list) (lambda (&rest _) nil)) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (cj/undo-kill-buffer 2)) (should (equal opened "/tmp/b.org")))) @@ -121,7 +121,7 @@ currently-open most-recent file was never skipped." ((symbol-function 'recentf-mode) (lambda (&rest _) t)) ((symbol-function 'buffer-list) (lambda (&rest _) nil)) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (cj/undo-kill-buffer 0)) (should-not opened))) @@ -134,7 +134,7 @@ not a wrong-type-argument from find-file on nil." (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) ((symbol-function 'recentf-mode) (lambda (&rest _) t)) ((symbol-function 'buffer-list) (lambda (&rest _) nil)) - ((symbol-function 'find-file) (lambda (f) (setq opened f)))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f)))) (should-error (cj/undo-kill-buffer 5) :type 'user-error)) (should-not opened))) diff --git a/tests/test-ui-theme-commands.el b/tests/test-ui-theme-commands.el index 4e3ce7f28..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: @@ -68,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-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 diff --git a/tests/test-video-audio-recording--build-video-command.el b/tests/test-video-audio-recording--build-video-command.el index 3b79c9ecb..4f2909784 100644 --- a/tests/test-video-audio-recording--build-video-command.el +++ b/tests/test-video-audio-recording--build-video-command.el @@ -21,7 +21,7 @@ "Wayland command pipes wf-recorder to ffmpeg." (let ((cj/recording-mic-boost 2.0) (cj/recording-system-volume 1.0)) - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) t))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) (let ((cmd (cj/recording--build-video-command "mic" "sys" "/tmp/out.mkv" t))) (should (string-match-p "wf-recorder.*|.*ffmpeg" cmd)) (should (string-match-p "-i pipe:0" cmd)) @@ -60,7 +60,7 @@ "Device names with special characters are shell-quoted in Wayland mode." (let ((cj/recording-mic-boost 1.0) (cj/recording-system-volume 1.0)) - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) t))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) (let ((cmd (cj/recording--build-video-command "device with spaces" "sys" "/tmp/out.mkv" t))) ;; shell-quote-argument escapes spaces with backslashes @@ -70,7 +70,7 @@ "Output filename with spaces is shell-quoted in Wayland mode." (let ((cj/recording-mic-boost 1.0) (cj/recording-system-volume 1.0)) - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) t))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) (let ((cmd (cj/recording--build-video-command "mic" "sys" "/tmp/my recording.mkv" t))) ;; Filename should be quoted/escaped @@ -103,7 +103,7 @@ (ert-deftest test-video-audio-recording--build-video-command-error-wayland-no-wf-recorder () "Wayland mode signals error when wf-recorder is not installed." - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) nil))) (should-error (cj/recording--build-video-command "mic" "sys" "/tmp/out.mkv" t) :type 'user-error))) diff --git a/tests/test-video-audio-recording--test-device.el b/tests/test-video-audio-recording--test-device.el index e701b69fd..aa85b4388 100644 --- a/tests/test-video-audio-recording--test-device.el +++ b/tests/test-video-audio-recording--test-device.el @@ -20,7 +20,7 @@ "Runs exactly 2 shell commands: ffmpeg to record, ffplay to playback." (let ((commands nil)) (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording--test-device "test-device" "test-" "GO!") (should (= 2 (length commands))) ;; ffmpeg runs first (pushed last due to stack order) @@ -31,7 +31,7 @@ "The provided device name appears in the ffmpeg command." (let ((commands nil)) (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording--test-device "alsa_input.usb-Jabra.mono" "mic-" "SPEAK!") (let ((ffmpeg-cmd (cadr commands))) (should (string-match-p "alsa_input.usb-Jabra.mono" ffmpeg-cmd)) @@ -43,7 +43,7 @@ "Device names with special characters are shell-quoted." (let ((commands nil)) (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording--test-device "device with spaces" "test-" "GO!") (let ((ffmpeg-cmd (cadr commands))) ;; shell-quote-argument should have escaped the spaces @@ -54,7 +54,7 @@ (ert-deftest test-video-audio-recording--test-device-error-ffmpeg-failure-no-crash () "Function completes without error even when ffmpeg returns non-zero." (cl-letf (((symbol-function 'shell-command) - (lambda (_cmd) 1))) + (lambda (_cmd &rest _) 1))) ;; Should not signal any error (cj/recording--test-device "dev" "test-" "GO!") (should t))) diff --git a/tests/test-video-audio-recording-check-ffmpeg.el b/tests/test-video-audio-recording-check-ffmpeg.el index 5c264b640..1d8f13247 100644 --- a/tests/test-video-audio-recording-check-ffmpeg.el +++ b/tests/test-video-audio-recording-check-ffmpeg.el @@ -20,7 +20,7 @@ (ert-deftest test-video-audio-recording-check-ffmpeg-normal-ffmpeg-found-returns-t () "Test that function returns t when ffmpeg is found." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) + (lambda (cmd &rest _) (when (equal cmd "ffmpeg") "/usr/bin/ffmpeg")))) (let ((result (cj/recording-check-ffmpeg))) (should (eq t result))))) @@ -30,13 +30,13 @@ (ert-deftest test-video-audio-recording-check-ffmpeg-error-ffmpeg-not-found-signals-error () "Test that function signals user-error when ffmpeg is not found." (cl-letf (((symbol-function 'executable-find) - (lambda (_cmd) nil))) + (lambda (_cmd &rest _) nil))) (should-error (cj/recording-check-ffmpeg) :type 'user-error))) (ert-deftest test-video-audio-recording-check-ffmpeg-error-message-mentions-pacman () "Test that error message includes installation command." (cl-letf (((symbol-function 'executable-find) - (lambda (_cmd) nil))) + (lambda (_cmd &rest _) nil))) (condition-case err (cj/recording-check-ffmpeg) (user-error diff --git a/tests/test-video-audio-recording-ffmpeg-functions.el b/tests/test-video-audio-recording-ffmpeg-functions.el index 549aa317f..4b3570a26 100644 --- a/tests/test-video-audio-recording-ffmpeg-functions.el +++ b/tests/test-video-audio-recording-ffmpeg-functions.el @@ -190,7 +190,7 @@ (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) ((symbol-function 'signal-process) - (lambda (_pid _sig) (setq signal-called t) 0)) + (lambda (_pid _sig &rest _) (setq signal-called t) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/video-recording-stop) @@ -231,7 +231,7 @@ (signal-called nil)) (setq cj/audio-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'signal-process) - (lambda (_pid _sig) (setq signal-called t) 0)) + (lambda (_pid _sig &rest _) (setq signal-called t) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/audio-recording-stop) @@ -287,7 +287,7 @@ (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) ((symbol-function 'signal-process) - (lambda (_pid _sig) (error "Signal failed")))) + (lambda (_pid _sig &rest _) (error "Signal failed")))) (condition-case _err (cj/video-recording-stop) (error (setq error-raised t))) @@ -303,7 +303,7 @@ (error-raised nil)) (setq cj/audio-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'signal-process) - (lambda (_pid _sig) (error "Signal failed")))) + (lambda (_pid _sig &rest _) (error "Signal failed")))) (condition-case _err (cj/audio-recording-stop) (error (setq error-raised t))) diff --git a/tests/test-video-audio-recording-process-cleanup.el b/tests/test-video-audio-recording-process-cleanup.el index 52177a17c..7cb261c16 100644 --- a/tests/test-video-audio-recording-process-cleanup.el +++ b/tests/test-video-audio-recording-process-cleanup.el @@ -53,7 +53,7 @@ (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) ((symbol-function 'signal-process) - (lambda (pid sig) + (lambda (pid sig &rest _) (setq signaled-pid pid) (setq signaled-sig sig) 0)) @@ -85,7 +85,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (push (cons 'pkill args) call-order)) 0)) ((symbol-function 'signal-process) - (lambda (_pid _sig) + (lambda (_pid _sig &rest _) (push 'signal call-order) 0)) ((symbol-function 'cj/recording--wait-for-exit) @@ -114,7 +114,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (when (equal program "pkill") (push args pkill-args-list)) 0)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/video-recording-stop) @@ -140,7 +140,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (when (equal program "pkill") (setq pkill-called t)) 0)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/video-recording-stop) @@ -206,7 +206,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (wait-timeout nil)) (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc timeout) (setq wait-called t) @@ -227,7 +227,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (warning-shown nil)) (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) nil)) ; Simulate timeout ((symbol-function 'message) @@ -247,7 +247,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (let ((fake-process (make-process :name "test-audio" :command '("sleep" "1000"))) (warning-shown nil)) (setq cj/audio-recording-ffmpeg-process fake-process) - (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) nil)) ; Simulate timeout ((symbol-function 'message) @@ -268,7 +268,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (wait-called nil) (wait-timeout nil)) (setq cj/audio-recording-ffmpeg-process fake-process) - (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc timeout) (setq wait-called t) diff --git a/tests/test-video-audio-recording-test-mic.el b/tests/test-video-audio-recording-test-mic.el index 60b9eb0b7..64ef0eaab 100644 --- a/tests/test-video-audio-recording-test-mic.el +++ b/tests/test-video-audio-recording-test-mic.el @@ -36,11 +36,11 @@ (let ((temp-file nil)) ;; Mock make-temp-file to capture filename (cl-letf (((symbol-function 'make-temp-file) - (lambda (prefix _dir-flag suffix) + (lambda (prefix _dir-flag suffix &rest _) (setq temp-file (concat prefix "12345" suffix)) temp-file)) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-mic) (should (string-match-p "\\.wav$" temp-file))))) (test-mic-teardown))) @@ -54,7 +54,7 @@ (let ((commands nil)) ;; Mock shell-command to capture all commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-mic) (should (= 2 (length commands))) ;; First command should be ffmpeg (stored last in list due to push) @@ -74,7 +74,7 @@ (let ((commands nil)) ;; Capture all shell commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-mic) (should (= 2 (length commands))) ;; Second command should be ffplay @@ -93,7 +93,7 @@ (cl-letf (((symbol-function 'message) (lambda (fmt &rest args) (push (apply #'format fmt args) messages))) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-mic) (should (>= (length messages) 3)) ;; Check for recording message @@ -135,7 +135,7 @@ (setq cj/recording-mic-device "test-mic-device") ;; Mock shell-command to fail (cl-letf (((symbol-function 'shell-command) - (lambda (_cmd) 1))) ;; Non-zero exit code + (lambda (_cmd &rest _) 1))) ;; Non-zero exit code ;; Should complete without crashing (ffmpeg errors are ignored) ;; No error is raised - function just completes (cj/recording-test-mic) diff --git a/tests/test-video-audio-recording-test-monitor.el b/tests/test-video-audio-recording-test-monitor.el index d821600f0..168e4f072 100644 --- a/tests/test-video-audio-recording-test-monitor.el +++ b/tests/test-video-audio-recording-test-monitor.el @@ -36,11 +36,11 @@ (let ((temp-file nil)) ;; Mock make-temp-file to capture filename (cl-letf (((symbol-function 'make-temp-file) - (lambda (prefix _dir-flag suffix) + (lambda (prefix _dir-flag suffix &rest _) (setq temp-file (concat prefix "12345" suffix)) temp-file)) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-monitor) (should (string-match-p "monitor-test-" temp-file)) (should (string-match-p "\\.wav$" temp-file))))) @@ -55,7 +55,7 @@ (let ((commands nil)) ;; Mock shell-command to capture all commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-monitor) (should (= 2 (length commands))) ;; First command should be ffmpeg (stored last in list due to push) @@ -75,7 +75,7 @@ (let ((commands nil)) ;; Capture all shell commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-monitor) (should (= 2 (length commands))) ;; Second command should be ffplay @@ -94,7 +94,7 @@ (cl-letf (((symbol-function 'message) (lambda (fmt &rest args) (push (apply #'format fmt args) messages))) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-monitor) (should (>= (length messages) 3)) ;; Check for recording message @@ -136,7 +136,7 @@ (setq cj/recording-system-device "test-monitor-device") ;; Mock shell-command to fail (cl-letf (((symbol-function 'shell-command) - (lambda (_cmd) 1))) ;; Non-zero exit code + (lambda (_cmd &rest _) 1))) ;; Non-zero exit code ;; Should complete without crashing (ffmpeg errors are ignored) ;; No error is raised - function just completes (cj/recording-test-monitor) diff --git a/tests/test-video-audio-recording-toggle-functions.el b/tests/test-video-audio-recording-toggle-functions.el index 2355ab4f6..cdd3096ac 100644 --- a/tests/test-video-audio-recording-toggle-functions.el +++ b/tests/test-video-audio-recording-toggle-functions.el @@ -84,7 +84,7 @@ (let ((prompt-called nil) (recorded-dir nil)) (cl-letf (((symbol-function 'read-directory-name) - (lambda (_prompt) (setq prompt-called t) "/custom/path/")) + (lambda (_prompt &rest _) (setq prompt-called t) "/custom/path/")) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ; Directory exists ((symbol-function 'cj/ffmpeg-record-video) @@ -139,7 +139,7 @@ (let ((prompt-called nil) (recorded-dir nil)) (cl-letf (((symbol-function 'read-directory-name) - (lambda (_prompt) (setq prompt-called t) "/custom/path/")) + (lambda (_prompt &rest _) (setq prompt-called t) "/custom/path/")) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ; Directory exists ((symbol-function 'cj/ffmpeg-record-audio) |