diff options
Diffstat (limited to 'tests')
95 files changed, 5870 insertions, 803 deletions
diff --git a/tests/test-ai-term--attached-agent-dirs.el b/tests/test-ai-term--attached-agent-dirs.el new file mode 100644 index 00000000..bdd69544 --- /dev/null +++ b/tests/test-ai-term--attached-agent-dirs.el @@ -0,0 +1,58 @@ +;;; test-ai-term--attached-agent-dirs.el --- Tests for cj/--ai-term-attached-agent-dirs -*- lexical-binding: t; -*- + +;;; Commentary: +;; The queue `cj/ai-term-next-attached' (M-SPC) steps through: project dirs +;; with a live agent BUFFER only -- attached sessions. Unlike +;; `cj/--ai-term-active-agent-dirs', detached tmux sessions with no Emacs +;; buffer are excluded; those are reachable only via `cj/ai-term-next' +;; (M-S-SPC). Candidates / buffers / sessions are mocked so the enumeration +;; logic is exercised without a real tmux server. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(ert-deftest test-ai-term--attached-agent-dirs-excludes-detached () + "Normal: only dirs with a live buffer are attached; a detached session is +excluded even though it is active." + (let ((buf (get-buffer-create (cj/--ai-term-buffer-name "/p/alpha")))) + (unwind-protect + (cl-letf (((symbol-function 'cj/--ai-term-candidates) + (lambda (&rest _) '("/p/alpha" "/p/beta" "/p/gamma" "/p/delta"))) + ((symbol-function 'cj/--ai-term-agent-buffers) + (lambda (&rest _) (list buf))) + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda (&rest _) (list (cj/--ai-term-tmux-session-name "/p/gamma"))))) + ;; alpha attached (buffer), gamma detached (session): only alpha. + (should (equal '("/p/alpha") (cj/--ai-term-attached-agent-dirs)))) + (kill-buffer buf)))) + +(ert-deftest test-ai-term--attached-agent-dirs-multiple-sorted () + "Normal: multiple attached dirs come back sorted by agent buffer name." + (let ((a (get-buffer-create (cj/--ai-term-buffer-name "/p/delta"))) + (b (get-buffer-create (cj/--ai-term-buffer-name "/p/alpha")))) + (unwind-protect + (cl-letf (((symbol-function 'cj/--ai-term-candidates) + (lambda (&rest _) '("/p/alpha" "/p/beta" "/p/delta"))) + ((symbol-function 'cj/--ai-term-agent-buffers) + (lambda (&rest _) (list a b))) + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda (&rest _) nil))) + (should (equal '("/p/alpha" "/p/delta") (cj/--ai-term-attached-agent-dirs)))) + (kill-buffer a) + (kill-buffer b)))) + +(ert-deftest test-ai-term--attached-agent-dirs-empty-when-only-detached () + "Boundary: sessions exist but no live buffers -> no attached dirs." + (cl-letf (((symbol-function 'cj/--ai-term-candidates) (lambda (&rest _) '("/p/solo"))) + ((symbol-function 'cj/--ai-term-agent-buffers) (lambda (&rest _) nil)) + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda (&rest _) (list (cj/--ai-term-tmux-session-name "/p/solo"))))) + (should (null (cj/--ai-term-attached-agent-dirs))))) + +(provide 'test-ai-term--attached-agent-dirs) +;;; test-ai-term--attached-agent-dirs.el ends here diff --git a/tests/test-ai-term--buffer-name.el b/tests/test-ai-term--buffer-name.el index b241977d..e728bc82 100644 --- a/tests/test-ai-term--buffer-name.el +++ b/tests/test-ai-term--buffer-name.el @@ -38,5 +38,26 @@ (should (equal (cj/--ai-term-buffer-name "/a/b/c/d/e/leaf") "agent [leaf]"))) +;;; Basename extraction (inverse transform) + +(ert-deftest test-ai-term--buffer-basename-normal-round-trip () + "Normal: extracts the basename embedded in an agent buffer's name." + (let ((buf (get-buffer-create "agent [proj]"))) + (unwind-protect + (should (equal (cj/--ai-term-buffer-basename buf) "proj")) + (kill-buffer buf)))) + +(ert-deftest test-ai-term--buffer-basename-boundary-dotted () + "Boundary: dotted basenames (.emacs.d) survive extraction intact." + (let ((buf (get-buffer-create "agent [.emacs.d]"))) + (unwind-protect + (should (equal (cj/--ai-term-buffer-basename buf) ".emacs.d")) + (kill-buffer buf)))) + +(ert-deftest test-ai-term--buffer-basename-error-non-agent-nil () + "Error: a non-agent buffer yields nil." + (with-temp-buffer + (should (null (cj/--ai-term-buffer-basename (current-buffer)))))) + (provide 'test-ai-term--buffer-name) ;;; test-ai-term--buffer-name.el ends here diff --git a/tests/test-ai-term--close.el b/tests/test-ai-term--close.el index 242bfd74..8b028351 100644 --- a/tests/test-ai-term--close.el +++ b/tests/test-ai-term--close.el @@ -36,8 +36,22 @@ (lambda (&rest _) (error "no tmux")))) (should (null (cj/--ai-term-kill-tmux-session "aiv-foo"))))) +(ert-deftest test-ai-term--close-buffer-session-from-name-after-cd () + "Regression: the session name comes from the immutable buffer name. +ghostel retargets `default-directory' via OSC 7 as the shell cds, so +deriving from it after a cd kills the wrong aiv- session (or misses, +orphaning the agent). The buffer name's basename never changes." + (let ((buf (get-buffer-create "agent [proj]")) + captured-session) + (with-current-buffer buf (setq-local default-directory "/tmp/elsewhere/")) + (cl-letf (((symbol-function 'cj/--ai-term-kill-tmux-session) + (lambda (s) (setq captured-session s) 0))) + (cj/--ai-term-close-buffer buf)) + (should (equal captured-session "aiv-proj")) + (should-not (buffer-live-p buf)))) + (ert-deftest test-ai-term--close-buffer-kills-session-and-buffer () - "Normal: derives the session from default-directory, kills it and the buffer." + "Normal: derives the session from the buffer name, kills it and the buffer." (let ((buf (get-buffer-create "agent [foo]")) captured-session) (with-current-buffer buf (setq-local default-directory "/tmp/foo/")) diff --git a/tests/test-ai-term--keybindings.el b/tests/test-ai-term--keybindings.el index 6f7f53a5..8b1f8fa5 100644 --- a/tests/test-ai-term--keybindings.el +++ b/tests/test-ai-term--keybindings.el @@ -33,14 +33,18 @@ (should (eq (keymap-lookup cj/custom-keymap "a") cj/ai-term-keymap))) (ert-deftest test-ai-term-next-bound-to-meta-space-globally () - "Normal: M-SPC runs `cj/ai-term-next' (the fast swap chord)." - (should (eq (lookup-key (current-global-map) (kbd "M-SPC")) #'cj/ai-term-next))) + "Normal: M-SPC runs `cj/ai-term-next-attached' (cycle attached only) and +M-S-SPC runs `cj/ai-term-next' (cycle all, including detached)." + (should (eq (lookup-key (current-global-map) (kbd "M-SPC")) #'cj/ai-term-next-attached)) + (should (eq (lookup-key (current-global-map) (kbd "M-S-SPC")) #'cj/ai-term-next))) (ert-deftest test-ai-term-meta-space-bound-in-eat-semi-char-mode-map () - "Normal: M-SPC is bound in `eat-semi-char-mode-map' so swap works inside an -agent. EAT forwards unbound keys to the pty, so the bind is what lets it reach -Emacs -- no ghostel-style exception list or rebuild is needed." - (should (eq (keymap-lookup eat-semi-char-mode-map "M-SPC") #'cj/ai-term-next))) + "Normal: both swap chords are bound in `eat-semi-char-mode-map' so they work +inside an agent. EAT forwards unbound keys to the pty, so the bind is what lets +them reach Emacs -- no ghostel-style exception list or rebuild is needed. M-SPC +cycles attached only; M-S-SPC cycles all." + (should (eq (keymap-lookup eat-semi-char-mode-map "M-SPC") #'cj/ai-term-next-attached)) + (should (eq (keymap-lookup eat-semi-char-mode-map "M-S-SPC") #'cj/ai-term-next))) (ert-deftest test-ai-term-f9-family-removed-globally () "Regression: the old F9 family no longer binds the ai-term commands globally." diff --git a/tests/test-ai-term--quit.el b/tests/test-ai-term--quit.el index 55ace81d..64b8a5d4 100644 --- a/tests/test-ai-term--quit.el +++ b/tests/test-ai-term--quit.el @@ -43,6 +43,22 @@ (should-not (buffer-live-p buf))) (when (buffer-live-p buf) (kill-buffer buf))))) +(ert-deftest test-ai-term-quit-nil-project-from-drifted-agent-buffer () + "Regression: nil PROJECT inside an agent buffer keys off the buffer name. +After a cd in the agent shell, ghostel's OSC 7 tracking moves the buffer's +`default-directory' away from the project, so keying off it would kill the +wrong session and miss the buffer." + (let ((buf (get-buffer-create "agent [realproj]")) + (calls nil)) + (unwind-protect + (test-ai-term-quit--with-tmux calls + (with-current-buffer buf + (setq-local default-directory "/tmp/elsewhere/") + (cj/ai-term-quit)) + (should (member '("kill-session" "-t" "aiv-realproj") calls)) + (should-not (buffer-live-p buf))) + (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-deftest test-ai-term-quit-idempotent-when-gone () "Error/Boundary: a second quit (session + buffer already gone) does not error." (let ((calls nil)) diff --git a/tests/test-ai-term--session-threading.el b/tests/test-ai-term--session-threading.el new file mode 100644 index 00000000..984f76d7 --- /dev/null +++ b/tests/test-ai-term--session-threading.el @@ -0,0 +1,40 @@ +;;; test-ai-term--session-threading.el --- Session-list threading tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The launch path used to call cj/--ai-term-live-tmux-sessions (a tmux +;; subprocess) once in the project picker, again for the launcher's fresh +;; check, and a third time inside show-or-create. One fetch per launch, +;; threaded through, is the contract pinned here. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(ert-deftest test-ai-term-launch-fetches-tmux-sessions-once () + "Normal: one tmux session fetch per launch, threaded to the picker and +show-or-create rather than re-spawned by each." + (let ((fetches 0) received-sessions) + (cl-letf (((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda () (setq fetches (1+ fetches)) '("other"))) + ((symbol-function 'cj/--ai-term-candidates) + (lambda () '("/tmp/proj/"))) + ((symbol-function 'completing-read) + (lambda (_prompt table &rest _) + (car (all-completions "" table)))) + ((symbol-function 'get-buffer) (lambda (_n) nil)) + ((symbol-function 'cj/--ai-term-pick-runtime) (lambda () 'claude)) + ((symbol-function 'cj/--ai-term-runtime-command) (lambda (_r) "cmd")) + ((symbol-function 'cj/--ai-term-show-or-create) + (lambda (_dir _name _cmd &optional sessions) + (setq received-sessions sessions) + (current-buffer))) + ((symbol-function 'get-buffer-window) (lambda (&rest _) nil))) + (cj/ai-term-pick-project t) + (should (= fetches 1)) + (should (equal received-sessions '("other")))))) + +(provide 'test-ai-term--session-threading) +;;; test-ai-term--session-threading.el ends here diff --git a/tests/test-ai-term--show-or-create.el b/tests/test-ai-term--show-or-create.el index 9574b8a6..64e37653 100644 --- a/tests/test-ai-term--show-or-create.el +++ b/tests/test-ai-term--show-or-create.el @@ -122,7 +122,8 @@ dashboard put and letting the alist place agent into a fresh split. This test stubs `eat' to mimic the same-window side-effect and asserts the originally-selected window still shows its original buffer afterward." (let ((agent-name "agent [preserve-window-test]") - (orig-name "*test-original-buffer*")) + (orig-name "*test-original-buffer*") + (subprocess-calls nil)) (test-ai-term--cleanup agent-name) (when (get-buffer orig-name) (kill-buffer orig-name)) (unwind-protect @@ -138,9 +139,21 @@ originally-selected window still shows its original buffer afterward." (set-window-buffer (selected-window) buf) buf))) ((symbol-function 'cj/--ai-term-send-string) - (lambda (_buf _s) nil))) + (lambda (_buf _s) nil)) + ;; Same hermetic seams the shared macro mocks: no tmux + ;; subprocess for the fresh-session check, no /color timer. + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda () nil)) + ((symbol-function 'cj/--ai-term-schedule-color) + (lambda (_buffer _color) nil)) + ;; Leak guard: any subprocess attempt is recorded, not run. + ;; `cj/--ai-term-live-tmux-sessions' swallows errors, so a + ;; signaling barrier would pass silently -- record and assert. + ((symbol-function 'process-file) + (lambda (&rest _) (push 'process-file subprocess-calls) -1))) (cj/--ai-term-show-or-create "/tmp/preserve" agent-name) - (should (eq (window-buffer orig-win) orig-buf))))) + (should (eq (window-buffer orig-win) orig-buf)) + (should-not subprocess-calls)))) (test-ai-term--cleanup agent-name) (when (get-buffer orig-name) (kill-buffer orig-name))))) diff --git a/tests/test-auto-dim-config.el b/tests/test-auto-dim-config.el index 12435fa0..dcab7eff 100644 --- a/tests/test-auto-dim-config.el +++ b/tests/test-auto-dim-config.el @@ -30,7 +30,12 @@ (progn (should (bound-and-true-p auto-dim-other-buffers-mode)) (should (null auto-dim-other-buffers-dim-on-focus-out)) - (should (eq t auto-dim-other-buffers-dim-on-switch-to-minibuffer)) + ;; Entering the minibuffer must not change what is dimmed: a dim window + ;; stays dim, a lit one stays lit. The fork's `adob--update' returns + ;; early when this is nil and the selected window is the minibuffer, so + ;; nil is what keeps a minibuffer prompt from re-dimming the window the + ;; user was just in. + (should (null auto-dim-other-buffers-dim-on-switch-to-minibuffer)) (should-not (assq 'fringe auto-dim-other-buffers-affected-faces))) (when (fboundp 'auto-dim-other-buffers-mode) (auto-dim-other-buffers-mode -1)))) diff --git a/tests/test-browser-config--preferred-default.el b/tests/test-browser-config--preferred-default.el new file mode 100644 index 00000000..113ad540 --- /dev/null +++ b/tests/test-browser-config--preferred-default.el @@ -0,0 +1,89 @@ +;;; test-browser-config--preferred-default.el --- Tests for the first-run browser pick -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for cj/--preferred-default-browser, the pure helper that picks +;; the first-run default when no saved choice exists. +;; +;; The behavior it fixes: EWW is listed first in `cj/browser-definitions' and +;; carries a nil executable, so `cj/discover-browsers' always reports it as +;; available and it sorted first. A fresh machine therefore opened every org +;; link in the Emacs text browser until the user found cj/choose-browser, even +;; with Chrome or Firefox installed. The helper prefers a real external +;; browser and keeps EWW as the genuine last resort. +;; +;; The helper takes the discovered list as an argument rather than calling +;; `cj/discover-browsers' itself, so these tests drive real data structures +;; and never stub executable-find. +;; +;; Test organization: +;; - Normal Cases: external browser preferred over a leading built-in +;; - Boundary Cases: only built-ins, only externals, single entry, empty list +;; - Error Cases: entries missing the :executable key +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'browser-config) + +(defconst test-browser--eww + '(:executable nil :function eww-browse-url :name "EWW (Emacs Browser)" + :path nil :program-var nil)) + +(defconst test-browser--chrome + '(:executable "google-chrome" :function browse-url-chrome :name "Google Chrome" + :path "/usr/bin/google-chrome" :program-var browse-url-chrome-program)) + +(defconst test-browser--firefox + '(:executable "firefox" :function browse-url-firefox :name "Firefox" + :path "/usr/bin/firefox" :program-var browse-url-firefox-program)) + +;;; Normal Cases + +(ert-deftest test-browser-config-preferred-default-skips-leading-builtin () + "Normal: an installed external browser wins over a built-in listed first." + (should (equal (cj/--preferred-default-browser + (list test-browser--eww test-browser--chrome)) + test-browser--chrome))) + +(ert-deftest test-browser-config-preferred-default-keeps-external-order () + "Normal: the FIRST external in list order wins, not merely any external." + (should (equal (cj/--preferred-default-browser + (list test-browser--eww test-browser--chrome test-browser--firefox)) + test-browser--chrome))) + +;;; Boundary Cases + +(ert-deftest test-browser-config-preferred-default-builtin-only-falls-back () + "Boundary: with no external installed, the built-in is still chosen." + (should (equal (cj/--preferred-default-browser (list test-browser--eww)) + test-browser--eww))) + +(ert-deftest test-browser-config-preferred-default-external-only () + "Boundary: a list of externals returns the first one." + (should (equal (cj/--preferred-default-browser + (list test-browser--firefox test-browser--chrome)) + test-browser--firefox))) + +(ert-deftest test-browser-config-preferred-default-empty-list-is-nil () + "Boundary: an empty discovery result yields nil, never an error." + (should (null (cj/--preferred-default-browser '())))) + +(ert-deftest test-browser-config-preferred-default-single-builtin () + "Boundary: a one-element built-in list returns that element." + (should (equal (cj/--preferred-default-browser (list test-browser--eww)) + test-browser--eww))) + +;;; Error Cases + +(ert-deftest test-browser-config-preferred-default-missing-executable-key () + "Error: a plist with no :executable key counts as built-in, not a crash." + (let ((malformed '(:name "Odd" :function ignore))) + (should (equal (cj/--preferred-default-browser + (list malformed test-browser--chrome)) + test-browser--chrome)) + (should (equal (cj/--preferred-default-browser (list malformed)) + malformed)))) + +(provide 'test-browser-config--preferred-default) +;;; test-browser-config--preferred-default.el ends here diff --git a/tests/test-calendar-sync--apply-recurrence-exceptions.el b/tests/test-calendar-sync--apply-recurrence-exceptions.el index 7711c5cb..999296fb 100644 --- a/tests/test-calendar-sync--apply-recurrence-exceptions.el +++ b/tests/test-calendar-sync--apply-recurrence-exceptions.el @@ -153,5 +153,36 @@ NEW-* values are the rescheduled time." (and (= 1 (length result)) (= 9 (nth 3 (plist-get (car result) :start))))))))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--apply-recurrence-exceptions-normal-cancelled-removes () + "Normal: a cancelled exception removes its occurrence instead of overriding it." + (let* ((occurrences (list (test-make-occurrence 2026 2 3 9 0 "Weekly Meeting") + (test-make-occurrence 2026 2 10 9 0 "Weekly Meeting") + (test-make-occurrence 2026 2 17 9 0 "Weekly Meeting"))) + (exceptions (make-hash-table :test 'equal))) + ;; Feb 10 is cancelled. + (puthash "test-event@google.com" + (list (append (test-make-exception-data 2026 2 10 9 0 2026 2 10 9 0) + '(:cancelled t))) + exceptions) + (let ((result (calendar-sync--apply-recurrence-exceptions occurrences exceptions))) + (should (= 2 (length result))) + ;; Feb 3 and Feb 17 remain; Feb 10 is gone. + (should (equal '(3 17) + (mapcar (lambda (occ) (nth 2 (plist-get occ :start))) result)))))) + +(ert-deftest test-calendar-sync--apply-recurrence-exceptions-boundary-cancelled-no-match-keeps-all () + "Boundary: a cancelled exception that matches nothing removes nothing." + (let* ((occurrences (list (test-make-occurrence 2026 2 3 9 0 "Weekly Meeting"))) + (exceptions (make-hash-table :test 'equal))) + ;; Cancelled exception targets a different date. + (puthash "test-event@google.com" + (list (append (test-make-exception-data 2026 3 3 9 0 2026 3 3 9 0) + '(:cancelled t))) + exceptions) + (let ((result (calendar-sync--apply-recurrence-exceptions occurrences exceptions))) + (should (= 1 (length result)))))) + (provide 'test-calendar-sync--apply-recurrence-exceptions) ;;; test-calendar-sync--apply-recurrence-exceptions.el ends here diff --git a/tests/test-calendar-sync--expand-daily.el b/tests/test-calendar-sync--expand-daily.el index 43b93664..0db9f345 100644 --- a/tests/test-calendar-sync--expand-daily.el +++ b/tests/test-calendar-sync--expand-daily.el @@ -176,5 +176,52 @@ (occurrences (calendar-sync--expand-daily base-event rrule range))) (should (= (length occurrences) 5)))) +;;; UNTIL is inclusive (RFC 5545 3.3.10) + +(ert-deftest test-calendar-sync--expand-daily-until-includes-the-until-date () + "Boundary: an occurrence falling ON the UNTIL date is kept. +RFC 5545 3.3.10: UNTIL bounds the recurrence \"in an inclusive manner\", and +when it lines up with the recurrence that date \"becomes the last instance\". +A strict before-comparison drops it, so the last meeting of every bounded +series silently vanishes from the agenda." + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-date (test-calendar-sync-time-date-only 5)) + (base-event (list :summary "Bounded Standup" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range)) + (last-start (plist-get (car (last occurrences)) :start))) + ;; day+1 through day+5 inclusive = 5 occurrences. + (should (= (length occurrences) 5)) + ;; The final occurrence is the UNTIL date itself. + (should (equal (seq-take last-start 3) until-date)))) + +(ert-deftest test-calendar-sync--expand-daily-until-excludes-dates-after-it () + "Boundary: inclusivity stops at UNTIL; the next day is not generated. +Guards the fix against over-correcting into an off-by-one the other way." + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-date (test-calendar-sync-time-date-only 5)) + (day-after (test-calendar-sync-time-date-only 6)) + (base-event (list :summary "Bounded Standup" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range)) + (dates (mapcar (lambda (o) (seq-take (plist-get o :start) 3)) occurrences))) + (should (member until-date dates)) + (should-not (member day-after dates)))) + +(ert-deftest test-calendar-sync--expand-daily-until-on-start-date-yields-one () + "Boundary: UNTIL equal to the start date yields exactly that one occurrence. +The degenerate single-instance series -- a strict comparison returns nothing +at all here, which is the same defect at its smallest." + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-date (test-calendar-sync-time-date-only 1)) + (base-event (list :summary "One Shot" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range))) + (should (= (length occurrences) 1)) + (should (equal (seq-take (plist-get (car occurrences) :start) 3) until-date)))) + (provide 'test-calendar-sync--expand-daily) ;;; test-calendar-sync--expand-daily.el ends here diff --git a/tests/test-calendar-sync--expand-monthly.el b/tests/test-calendar-sync--expand-monthly.el index 3dc1f2dc..41b196a7 100644 --- a/tests/test-calendar-sync--expand-monthly.el +++ b/tests/test-calendar-sync--expand-monthly.el @@ -170,5 +170,124 @@ (occurrences (calendar-sync--expand-monthly base-event rrule range))) (should (= (length occurrences) 3)))) +;;; BYDAY (nth weekday) Cases +;; +;; Fixed dates are deterministic here: the expansion range is an explicit +;; parameter, not derived from the current time, so these never age out. + +(defun test-calendar-sync--expand-monthly-range-2026 () + "Fixed expansion range covering calendar year 2026." + (list (encode-time 0 0 0 1 1 2026) (encode-time 0 0 0 31 12 2026))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-second-wednesday () + "Normal: BYDAY=2WE lands on the 2nd Wednesday of each month, not the +day-of-month of DTSTART. This is the live Craig/Ryan series shape." + (let* ((base-event (list :summary "2nd Wednesday" + :start '(2026 1 14 10 0) + :end '(2026 1 14 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("2WE"))) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + (should (equal days '((1 14) (2 11) (3 11) (4 8) (5 13) (6 10) + (7 8) (8 12) (9 9) (10 14) (11 11) (12 9)))) + ;; Every occurrence is a Wednesday (weekday 3), never a fixed day-of-month. + (dolist (occ occurrences) + (let ((s (plist-get occ :start))) + (should (= 3 (calendar-sync--date-weekday + (list (nth 0 s) (nth 1 s) (nth 2 s))))))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-last-tuesday () + "Normal: BYDAY=-1TU lands on the last Tuesday of each month." + (let* ((base-event (list :summary "Last Tuesday" + :start '(2026 1 27 9 0) + :end '(2026 1 27 10 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("-1TU") :count 3)) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + (should (equal days '((1 27) (2 24) (3 31)))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-bysetpos-second-sunday () + "Normal: BYDAY=SU with BYSETPOS=2 lands on the 2nd Sunday (Proton shape)." + (let* ((base-event (list :summary "2nd Sunday" + :start '(2026 1 11 8 0) + :end '(2026 1 11 9 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("SU") :bysetpos 2 :count 3)) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + (should (equal days '((1 11) (2 8) (3 8)))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-until-inclusive-and-reached () + "Boundary: with BYDAY, UNTIL is inclusive and the series reaches it. +Upper bound alone can't catch a dropped final occurrence -- assert both." + (let* ((base-event (list :summary "Bounded" + :start '(2026 1 14 10 0) + :end '(2026 1 14 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("2WE") + :until '(2026 5 13))) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (last-start (plist-get (car (last occurrences)) :start))) + (should (= (length occurrences) 5)) + ;; Reach: the occurrence landing exactly on UNTIL is kept. + (should (equal (list (nth 0 last-start) (nth 1 last-start) (nth 2 last-start)) + '(2026 5 13))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-count-limits () + "Boundary: COUNT caps a BYDAY series." + (let* ((base-event (list :summary "Counted" + :start '(2026 1 14 10 0) + :end '(2026 1 14 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("2WE") :count 4)) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range))) + (should (= (length occurrences) 4)))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-fifth-weekday-skips-short-months () + "Boundary: BYDAY=5WE only lands in months that have a 5th Wednesday." + (let* ((base-event (list :summary "5th Wednesday" + :start '(2026 4 29 10 0) + :end '(2026 4 29 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("5WE"))) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + ;; 2026 months (Apr on) with a 5th Wednesday: Apr 29, Jul 29, Sep 30, Dec 30. + (should (equal days '((4 29) (7 29) (9 30) (12 30)))))) + +(ert-deftest test-calendar-sync--expand-monthly-on-31st-skips-short-months () + "Boundary: a plain monthly rule on the 31st skips months without a 31st. +The stepper kept day-of-month verbatim, so Jan 31 stepped to Feb 31, +which encode-time normalizes to Mar 3 -- phantom mis-dated occurrences +instead of the RFC 5545 skip." + (let* ((base-event (list :summary "Monthly on the 31st" + :start '(2030 1 31 10 0) + :end '(2030 1 31 11 0))) + (rrule (list :freq 'monthly :interval 1)) + ;; End the range past Dec 31: the range end is midnight, so ending + ;; ON the 31st would exclude that day's 10:00 occurrence. + (range (list (calendar-sync--date-to-time '(2030 1 1)) + (calendar-sync--date-to-time '(2031 1 1)))) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (months (mapcar (lambda (o) (nth 1 (plist-get o :start))) occurrences)) + (days (mapcar (lambda (o) (nth 2 (plist-get o :start))) occurrences))) + ;; Only the seven 31-day months of 2030, each on the 31st. + (should (equal months '(1 3 5 7 8 10 12))) + (should (equal days '(31 31 31 31 31 31 31))))) + (provide 'test-calendar-sync--expand-monthly) ;;; test-calendar-sync--expand-monthly.el ends here diff --git a/tests/test-calendar-sync--expand-weekly.el b/tests/test-calendar-sync--expand-weekly.el index a6143bce..0639ca07 100644 --- a/tests/test-calendar-sync--expand-weekly.el +++ b/tests/test-calendar-sync--expand-weekly.el @@ -270,5 +270,33 @@ (should (= (length occurrences) 0))) (test-calendar-sync--expand-weekly-teardown))) +;;; UNTIL is inclusive (RFC 5545 3.3.10) + +(ert-deftest test-calendar-sync--expand-weekly-until-includes-the-until-date () + "Boundary: a weekly occurrence landing ON the UNTIL date is kept. +The weekly loop checks UNTIL in two places -- the outer week-stepping guard +and the per-weekday check inside it -- so it needs its own guard rather than +inheriting the daily one. Fixing the loop without this test left weekly +silently unprotected: reverting the fix failed three daily tests and zero +weekly ones." + (test-calendar-sync--expand-weekly-setup) + (unwind-protect + ;; Omitting :byday makes the series recur on the start date's own weekday, + ;; which anchors UNTIL exactly on an occurrence without hardcoding a date. + (let* ((start-date (test-calendar-sync-time-days-from-now 1 9 0)) + (week-2 (test-calendar-sync-time-date-only 8)) + (until-date (test-calendar-sync-time-date-only 15)) + (week-4 (test-calendar-sync-time-date-only 22)) + (base-event (list :summary "Bounded Weekly" :start start-date)) + (rrule (list :freq 'weekly :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-weekly base-event rrule range)) + (dates (mapcar (lambda (o) (seq-take (plist-get o :start) 3)) occurrences))) + ;; day+1, +8, +15 are consecutive same-weekday dates; UNTIL is the third. + (should (equal dates (list (seq-take start-date 3) week-2 until-date))) + ;; Inclusivity stops at UNTIL -- the following week is not generated. + (should-not (member week-4 dates))) + (test-calendar-sync--expand-weekly-teardown))) + (provide 'test-calendar-sync--expand-weekly) ;;; test-calendar-sync--expand-weekly.el ends here diff --git a/tests/test-calendar-sync--expand-yearly.el b/tests/test-calendar-sync--expand-yearly.el index ad9b8f27..c636e54a 100644 --- a/tests/test-calendar-sync--expand-yearly.el +++ b/tests/test-calendar-sync--expand-yearly.el @@ -175,5 +175,31 @@ (occurrences (calendar-sync--expand-yearly base-event rrule range))) (should (= (length occurrences) 2)))) +;;; BYMONTH + BYDAY (nth weekday) Cases +;; +;; Fixed dates are deterministic here: the expansion range is an explicit +;; parameter, not derived from the current time. + +(ert-deftest test-calendar-sync--expand-yearly-bymonth-byday-nth-weekday () + "Normal: FREQ=YEARLY;BYMONTH=3;BYDAY=2SU tracks the 2nd Sunday of March +each year (the DST clock-change shape), not DTSTART's calendar date." + (let* ((base-event (list :summary "Clocks change" + :start '(2026 3 8 2 0) + :end '(2026 3 8 3 0))) + (rrule (list :freq 'yearly :interval 1 :bymonth 3 :byday '("2SU"))) + (range (list (encode-time 0 0 0 1 1 2026) + (encode-time 0 0 0 31 12 2027))) + (occurrences (calendar-sync--expand-yearly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 0 s) (nth 1 s) (nth 2 s)))) + occurrences))) + ;; 2nd Sunday of March: 2026-03-08, 2027-03-14 -- different day-of-month. + (should (equal days '((2026 3 8) (2027 3 14)))) + (dolist (occ occurrences) + (let ((s (plist-get occ :start))) + (should (= 7 (calendar-sync--date-weekday + (list (nth 0 s) (nth 1 s) (nth 2 s))))))))) + (provide 'test-calendar-sync--expand-yearly) ;;; test-calendar-sync--expand-yearly.el ends here diff --git a/tests/test-calendar-sync--format-timestamp.el b/tests/test-calendar-sync--format-timestamp.el index 5b8a6d02..b84e625d 100644 --- a/tests/test-calendar-sync--format-timestamp.el +++ b/tests/test-calendar-sync--format-timestamp.el @@ -56,5 +56,59 @@ ;; start-hour is nil so time-str should be nil (should-not (string-match-p "[0-9][0-9]:[0-9][0-9]-" result)))) +;;; Multi-day spans (org range syntax) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-timed-spans-dates () + "A timed event ending on a later date renders as an org range. +The end DATE used to be discarded and only its time kept, so a four-day +conference produced the same timestamp as a same-day meeting and the agenda +showed it on day one only." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 14 0) '(2026 3 18 15 30)))) + (should (equal result "<2026-03-15 Sun 14:00>--<2026-03-18 Wed 15:30>")))) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-all-day-excludes-dtend () + "An all-day span ends the day before DTEND, which is non-inclusive. +RFC 5545 3.6.1: DTEND is \"the non-inclusive end of the event\", so an +all-day event running Mar 15-17 carries DTEND 2026-03-18. Rendering DTEND +verbatim would add a phantom fourth day." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 nil nil) '(2026 3 18 nil nil)))) + (should (equal result "<2026-03-15 Sun>--<2026-03-17 Tue>")))) + +(ert-deftest test-calendar-sync--format-timestamp-single-all-day-stays-single () + "A one-day all-day event stays a single stamp, never a degenerate range. +Its DTEND is the next day (non-inclusive), so a naive range would turn every +single all-day event into a two-day one -- a worse regression than the +collapse this range support fixes." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 nil nil) '(2026 3 16 nil nil)))) + (should (equal result "<2026-03-15 Sun>")) + (should-not (string-match-p "--" result)))) + +(ert-deftest test-calendar-sync--format-timestamp-same-day-timed-stays-compact () + "A same-day timed event keeps the compact HH:MM-HH:MM form, not a range. +Guards the common case against the range branch." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 14 0) '(2026 3 15 15 30)))) + (should (equal result "<2026-03-15 Sun 14:00-15:30>")) + (should-not (string-match-p "--" result)))) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-all-day-two-days () + "Boundary: the shortest real all-day span (two days) renders as a range. +DTEND 2026-03-17 means the event covers Mar 15-16; one day fewer and it +collapses to the single-stamp case above." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 nil nil) '(2026 3 17 nil nil)))) + (should (equal result "<2026-03-15 Sun>--<2026-03-16 Mon>")))) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-span-crosses-month () + "Boundary: an all-day span crossing a month boundary decrements correctly. +DTEND 2026-04-01 means the event's last day is 2026-03-31, which exercises +the borrow in `calendar-sync--add-days'." + (let ((result (calendar-sync--format-timestamp + '(2026 3 30 nil nil) '(2026 4 1 nil nil)))) + (should (equal result "<2026-03-30 Mon>--<2026-03-31 Tue>")))) + (provide 'test-calendar-sync--format-timestamp) ;;; test-calendar-sync--format-timestamp.el ends here diff --git a/tests/test-calendar-sync--nth-weekday-of-month.el b/tests/test-calendar-sync--nth-weekday-of-month.el new file mode 100644 index 00000000..afb0bd35 --- /dev/null +++ b/tests/test-calendar-sync--nth-weekday-of-month.el @@ -0,0 +1,67 @@ +;;; test-calendar-sync--nth-weekday-of-month.el --- Tests for calendar-sync--nth-weekday-of-month -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the nth-weekday-of-month helper backing monthly/yearly BYDAY +;; expansion. Fixed dates are safe here: the function is pure calendar +;; arithmetic with no relation to the current time. + +;;; Code: + +(require 'ert) +(require 'calendar-sync) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-second-wednesday () + "Normal: 2nd Wednesday of Jan 2026 is the 14th." + ;; Jan 2026: Jan 1 is a Thursday; Wednesdays fall on 7, 14, 21, 28. + (should (= (calendar-sync--nth-weekday-of-month 2026 1 3 2) 14))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-first-monday () + "Normal: 1st Monday of Feb 2026 is the 2nd." + ;; Feb 2026: Feb 1 is a Sunday; Mondays fall on 2, 9, 16, 23. + (should (= (calendar-sync--nth-weekday-of-month 2026 2 1 1) 2))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-last-tuesday () + "Normal: last Tuesday of Mar 2026 is the 31st (negative ordinal)." + ;; Mar 2026: Tuesdays fall on 3, 10, 17, 24, 31. + (should (= (calendar-sync--nth-weekday-of-month 2026 3 2 -1) 31))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-second-to-last-friday () + "Normal: -2 ordinal picks the second-to-last Friday." + ;; May 2026: Fridays fall on 1, 8, 15, 22, 29. + (should (= (calendar-sync--nth-weekday-of-month 2026 5 5 -2) 22))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-fifth-occurrence-exists () + "Boundary: 5th Friday exists in May 2026." + (should (= (calendar-sync--nth-weekday-of-month 2026 5 5 5) 29))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-fifth-occurrence-missing () + "Boundary: 5th Wednesday of Feb 2026 does not exist -- returns nil." + ;; Feb 2026 has four Wednesdays (4, 11, 18, 25). + (should (null (calendar-sync--nth-weekday-of-month 2026 2 3 5)))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-first-day-is-target () + "Boundary: the 1st of the month itself is the 1st occurrence." + ;; Apr 2026: Apr 1 is a Wednesday. + (should (= (calendar-sync--nth-weekday-of-month 2026 4 3 1) 1))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-leap-february () + "Boundary: leap-year February (2028) handled -- last Tuesday is the 29th." + ;; Feb 2028: Feb 29 exists and is a Tuesday. + (should (= (calendar-sync--nth-weekday-of-month 2028 2 2 -1) 29))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-error-zero-ordinal-nil () + "Error: ordinal 0 is meaningless -- returns nil." + (should (null (calendar-sync--nth-weekday-of-month 2026 1 3 0)))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-error-out-of-range-negative-nil () + "Error: -6th occurrence never exists in a month -- returns nil." + (should (null (calendar-sync--nth-weekday-of-month 2026 1 3 -6)))) + +(provide 'test-calendar-sync--nth-weekday-of-month) +;;; test-calendar-sync--nth-weekday-of-month.el ends here diff --git a/tests/test-calendar-sync--parse-byday-entry.el b/tests/test-calendar-sync--parse-byday-entry.el new file mode 100644 index 00000000..4a9b4ef5 --- /dev/null +++ b/tests/test-calendar-sync--parse-byday-entry.el @@ -0,0 +1,41 @@ +;;; test-calendar-sync--parse-byday-entry.el --- Tests for calendar-sync--parse-byday-entry -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for parsing a single RRULE BYDAY entry ("2WE", "-1TU", "SU") into +;; an (ordinal . weekday-number) cons. Ordinal is nil for a bare weekday. + +;;; Code: + +(require 'ert) +(require 'calendar-sync) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-positive-ordinal () + "Normal: \"2WE\" parses to ordinal 2, Wednesday (3)." + (should (equal (calendar-sync--parse-byday-entry "2WE") '(2 . 3)))) + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-negative-ordinal () + "Normal: \"-1TU\" parses to ordinal -1, Tuesday (2)." + (should (equal (calendar-sync--parse-byday-entry "-1TU") '(-1 . 2)))) + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-bare-weekday () + "Normal: \"SU\" parses to nil ordinal, Sunday (7)." + (should (equal (calendar-sync--parse-byday-entry "SU") '(nil . 7)))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-boundary-double-digit-ordinal () + "Boundary: \"53MO\" (yearly-scale ordinal) parses without truncation." + (should (equal (calendar-sync--parse-byday-entry "53MO") '(53 . 1)))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-error-garbage-nil () + "Error: an unrecognizable entry returns nil." + (should (null (calendar-sync--parse-byday-entry "XX"))) + (should (null (calendar-sync--parse-byday-entry ""))) + (should (null (calendar-sync--parse-byday-entry nil)))) + +(provide 'test-calendar-sync--parse-byday-entry) +;;; test-calendar-sync--parse-byday-entry.el ends here diff --git a/tests/test-calendar-sync--parse-event.el b/tests/test-calendar-sync--parse-event.el index 9c343db2..b3f58ba2 100644 --- a/tests/test-calendar-sync--parse-event.el +++ b/tests/test-calendar-sync--parse-event.el @@ -78,5 +78,37 @@ (let ((vevent "BEGIN:VEVENT\nSUMMARY:Orphan\nEND:VEVENT")) (should (null (calendar-sync--parse-event vevent))))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--parse-event-error-cancelled-returns-nil () + "Error: a STATUS:CANCELLED event returns nil -- cancelled events don't render." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Cancelled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:CANCELLED\n" + "END:VEVENT"))) + (should (null (calendar-sync--parse-event vevent))))) + +(ert-deftest test-calendar-sync--parse-event-boundary-cancelled-case-insensitive () + "Boundary: STATUS value matching is case-insensitive." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Cancelled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:Cancelled\n" + "END:VEVENT"))) + (should (null (calendar-sync--parse-event vevent))))) + +(ert-deftest test-calendar-sync--parse-event-normal-confirmed-still-parses () + "Normal: STATUS:CONFIRMED events still parse." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Confirmed Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:CONFIRMED\n" + "END:VEVENT"))) + (should (calendar-sync--parse-event vevent)))) + (provide 'test-calendar-sync--parse-event) ;;; test-calendar-sync--parse-event.el ends here diff --git a/tests/test-calendar-sync--parse-exception-event.el b/tests/test-calendar-sync--parse-exception-event.el index a26a7418..1c9411f3 100644 --- a/tests/test-calendar-sync--parse-exception-event.el +++ b/tests/test-calendar-sync--parse-exception-event.el @@ -82,5 +82,33 @@ than a half-built plist." "END:VEVENT"))) (should-not (calendar-sync--parse-exception-event event)))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--parse-exception-event-normal-cancelled-flag () + "Normal: a STATUS:CANCELLED override carries :cancelled t, so the +matching occurrence can be removed rather than overridden." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (event (concat "BEGIN:VEVENT\n" + "UID:override@google.com\n" + "RECURRENCE-ID:20260203T090000Z\n" + "SUMMARY:Craig / Ryan\n" + "STATUS:CANCELLED\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "DTEND:" (test-calendar-sync-ics-datetime end) "\n" + "END:VEVENT")) + (plist (calendar-sync--parse-exception-event event))) + (should plist) + (should (plist-get plist :cancelled)))) + +(ert-deftest test-calendar-sync--parse-exception-event-boundary-no-status-not-cancelled () + "Boundary: an override without STATUS is not cancelled." + (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-not (plist-get plist :cancelled)))) + (provide 'test-calendar-sync--parse-exception-event) ;;; test-calendar-sync--parse-exception-event.el ends here diff --git a/tests/test-calendar-sync--parse-rrule.el b/tests/test-calendar-sync--parse-rrule.el index 099e4e44..2668c1ac 100644 --- a/tests/test-calendar-sync--parse-rrule.el +++ b/tests/test-calendar-sync--parse-rrule.el @@ -206,5 +206,26 @@ (should (= (plist-get result :count) 10))) (test-calendar-sync--parse-rrule-teardown))) +;;; BYSETPOS / BYMONTH Cases + +(ert-deftest test-calendar-sync--parse-rrule-normal-bysetpos-returns-number () + "Normal: BYSETPOS parses to a number (Proton emits BYDAY=SU;BYSETPOS=2)." + (let ((result (calendar-sync--parse-rrule "FREQ=MONTHLY;BYDAY=SU;BYSETPOS=2"))) + (should (eq (plist-get result :freq) 'monthly)) + (should (equal (plist-get result :byday) '("SU"))) + (should (= (plist-get result :bysetpos) 2)))) + +(ert-deftest test-calendar-sync--parse-rrule-normal-bymonth-returns-number () + "Normal: BYMONTH parses to a number (yearly nth-weekday rules carry it)." + (let ((result (calendar-sync--parse-rrule "FREQ=YEARLY;BYMONTH=3;BYDAY=2SU"))) + (should (eq (plist-get result :freq) 'yearly)) + (should (= (plist-get result :bymonth) 3)) + (should (equal (plist-get result :byday) '("2SU"))))) + +(ert-deftest test-calendar-sync--parse-rrule-boundary-negative-bysetpos () + "Boundary: negative BYSETPOS (last matching day) parses." + (let ((result (calendar-sync--parse-rrule "FREQ=MONTHLY;BYDAY=FR;BYSETPOS=-1"))) + (should (= (plist-get result :bysetpos) -1)))) + (provide 'test-calendar-sync--parse-rrule) ;;; test-calendar-sync--parse-rrule.el ends here diff --git a/tests/test-calendar-sync--syncing-p.el b/tests/test-calendar-sync--syncing-p.el index b346bf77..df8bcd52 100644 --- a/tests/test-calendar-sync--syncing-p.el +++ b/tests/test-calendar-sync--syncing-p.el @@ -4,81 +4,111 @@ ;; Unit tests for `calendar-sync--syncing-p' (the per-calendar in-flight check ;; that lets the dispatcher skip an overlapping timer tick) and for the ;; load-state sanitize that clears a stale `syncing' status in a fresh process. +;; +;; Every test runs inside `test-cs-syncing--with-fresh-state', which let-binds +;; a private state hash. These tests previously cleared the module's global +;; hash on entry and left whatever they wrote in it on exit, which leaked: +;; `...-sync-calendar-skips-when-in-flight' marks "proton" as syncing to +;; exercise the guard, and `test-calendar-sync--sync-dispatch-normal-ics-fetcher' +;; in the sibling dispatch file dispatches a calendar also named "proton". +;; ERT runs them in that order, so the leftover in-flight status made the +;; dispatch a no-op and the sibling failed -- but only when the calendar-sync +;; files ran in one process. `make test' runs each file separately and the +;; editor hook skipped this family for being over its file cap, so nothing +;; caught it. Let-binding is what the sibling files already do +;; (test-calendar-sync.el, test-calendar-sync-async-worker.el); this file was +;; the odd one out. ;;; Code: (require 'ert) (require 'calendar-sync) -(defun test-cs-syncing--reset () - "Clear the module's per-calendar state hash." - (clrhash calendar-sync--calendar-states)) +(defmacro test-cs-syncing--with-fresh-state (&rest body) + "Run BODY with a private, empty per-calendar state hash. +Let-bound rather than cleared in place, so nothing this test writes can +reach a later test." + (declare (indent 0)) + `(let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + ,@body)) ;;; calendar-sync--syncing-p (ert-deftest test-calendar-sync--syncing-p-normal-true-when-syncing () "Normal: a calendar whose status is `syncing' reads as in-flight." - (test-cs-syncing--reset) - (calendar-sync--set-calendar-state "google" '(:status syncing)) - (should (calendar-sync--syncing-p "google"))) + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "google" '(:status syncing)) + (should (calendar-sync--syncing-p "google")))) (ert-deftest test-calendar-sync--syncing-p-boundary-nil-when-no-state () "Boundary: a calendar with no recorded state is not in-flight." - (test-cs-syncing--reset) - (should-not (calendar-sync--syncing-p "never-seen"))) + (test-cs-syncing--with-fresh-state + (should-not (calendar-sync--syncing-p "never-seen")))) (ert-deftest test-calendar-sync--syncing-p-error-nil-for-terminal-status () "Error: a terminal status (ok / error) is not in-flight." - (test-cs-syncing--reset) - (calendar-sync--set-calendar-state "google" '(:status ok)) - (should-not (calendar-sync--syncing-p "google")) - (calendar-sync--set-calendar-state "proton" '(:status error)) - (should-not (calendar-sync--syncing-p "proton"))) + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "google" '(:status ok)) + (should-not (calendar-sync--syncing-p "google")) + (calendar-sync--set-calendar-state "proton" '(:status error)) + (should-not (calendar-sync--syncing-p "proton")))) ;;; Dispatcher guard: an in-flight calendar skips both leaf syncers (ert-deftest test-calendar-sync--sync-calendar-skips-when-in-flight () "Normal: `calendar-sync--sync-calendar' does not launch a second sync for a calendar already marked syncing, so an overlapping timer tick is a no-op." - (test-cs-syncing--reset) - (let ((api-calls '()) (ics-calls '())) - (cl-letf (((symbol-function 'calendar-sync--sync-calendar-api) - (lambda (cal) (push cal api-calls))) - ((symbol-function 'calendar-sync--sync-calendar-ics) - (lambda (cal) (push cal ics-calls)))) - (calendar-sync--set-calendar-state "proton" '(:status syncing)) - (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" - :file "/tmp/c.org")) - (should (null api-calls)) - (should (null ics-calls))))) + (test-cs-syncing--with-fresh-state + (let ((api-calls '()) (ics-calls '())) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-api) + (lambda (cal) (push cal api-calls))) + ((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) (push cal ics-calls)))) + (calendar-sync--set-calendar-state "proton" '(:status syncing)) + (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" + :file "/tmp/c.org")) + (should (null api-calls)) + (should (null ics-calls)))))) (ert-deftest test-calendar-sync--sync-calendar-dispatches-when-idle () "Boundary: an idle calendar (no in-flight status) still dispatches normally." - (test-cs-syncing--reset) - (let ((ics-calls '())) - (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) - (lambda (cal) (push cal ics-calls)))) - (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" - :file "/tmp/c.org")) - (should (= 1 (length ics-calls)))))) + (test-cs-syncing--with-fresh-state + (let ((ics-calls '())) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) (push cal ics-calls)))) + (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" + :file "/tmp/c.org")) + (should (= 1 (length ics-calls))))))) + +;;; Isolation guard + +(ert-deftest test-calendar-sync--syncing-state-does-not-leak () + "Error: state written inside the macro is gone once it returns. +Pins the isolation itself. Without it a test marking a calendar syncing +leaves that status set for every later test in the same process, which is +exactly what broke the sibling dispatch test." + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "leak-probe" '(:status syncing)) + (should (calendar-sync--syncing-p "leak-probe"))) + (should-not (calendar-sync--syncing-p "leak-probe"))) ;;; load-state sanitize: a persisted `syncing' status is cleared on load (ert-deftest test-calendar-sync--load-state-clears-stale-syncing () "Error: a `syncing' status persisted before a crash is reset on load, so the in-flight guard cannot skip that calendar forever in the new session." - (test-cs-syncing--reset) - (let* ((dir (make-temp-file "cs-state-" t)) - (calendar-sync--state-file (expand-file-name "state.el" dir))) - (unwind-protect - (progn - (with-temp-file calendar-sync--state-file - (prin1 '((timezone-offset . nil) - (calendar-states . (("google" . (:status syncing))))) - (current-buffer))) - (calendar-sync--load-state) - (should-not (calendar-sync--syncing-p "google"))) - (delete-directory dir t)))) + (test-cs-syncing--with-fresh-state + (let* ((dir (make-temp-file "cs-state-" t)) + (calendar-sync--state-file (expand-file-name "state.el" dir))) + (unwind-protect + (progn + (with-temp-file calendar-sync--state-file + (prin1 '((timezone-offset . nil) + (calendar-states . (("google" . (:status syncing))))) + (current-buffer))) + (calendar-sync--load-state) + (should-not (calendar-sync--syncing-p "google"))) + (delete-directory dir t))))) (provide 'test-calendar-sync--syncing-p) ;;; test-calendar-sync--syncing-p.el ends here diff --git a/tests/test-calendar-sync-properties.el b/tests/test-calendar-sync-properties.el index c25bb99f..0b01cbd9 100644 --- a/tests/test-calendar-sync-properties.el +++ b/tests/test-calendar-sync-properties.el @@ -77,12 +77,21 @@ For any COUNT value N, expansion never produces more than N occurrences." ;;; Property 2: UNTIL Boundary +;; These two asserted the wrong invariant until 2026-07-16: they required every +;; occurrence to fall strictly BEFORE UNTIL, which is the exclusive reading RFC +;; 5545 3.3.10 contradicts ("bounds the recurrence rule in an inclusive manner"; +;; a UNTIL synchronized with the recurrence "becomes the last instance"). They +;; were written against the expansion loop's strict `before-date-p' guard and so +;; pinned the very defect that dropped the last instance of every bounded series. +;; The property is on-or-before; the upper bound is what UNTIL is for. + (ert-deftest test-calendar-sync-property-until-bounds-daily () - "Property: No daily occurrence starts on or after UNTIL date." + "Property: no daily occurrence starts after the UNTIL date. +UNTIL is an inclusive bound (RFC 5545 3.3.10), so landing exactly on it is +correct and only a later date violates the property." (dotimes (_ test-calendar-sync-property-trials) (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) (until-days (+ 10 (random 60))) - ;; UNTIL must be date-only (3 elements) for calendar-sync--before-date-p (until-date (test-calendar-sync-time-date-only until-days)) (base-event (list :summary "Until Test" :start start-date)) (rrule (list :freq 'daily :interval 1 :until until-date)) @@ -90,16 +99,35 @@ For any COUNT value N, expansion never produces more than N occurrences." (occurrences (calendar-sync--expand-daily base-event rrule range))) (dolist (occ occurrences) (let ((occ-start (plist-get occ :start))) - (should (calendar-sync--before-date-p + (should (calendar-sync--date-on-or-before-p (list (nth 0 occ-start) (nth 1 occ-start) (nth 2 occ-start)) until-date))))))) +(ert-deftest test-calendar-sync-property-until-bounds-daily-reaches-until () + "Property: a daily series stepping by one day always reaches its UNTIL date. +With interval 1 the recurrence is synchronized with any UNTIL, so the last +instance must be UNTIL itself. This is the half the old exclusive property +could never have caught -- it only bounded from above, so silently dropping +the final occurrence satisfied it." + (dotimes (_ test-calendar-sync-property-trials) + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-days (+ 10 (random 60))) + (until-date (test-calendar-sync-time-date-only until-days)) + (base-event (list :summary "Until Test" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range)) + (last-start (plist-get (car (last occurrences)) :start))) + (should occurrences) + (should (equal (seq-take last-start 3) until-date))))) + (ert-deftest test-calendar-sync-property-until-bounds-weekly () - "Property: No weekly occurrence starts on or after UNTIL date." + "Property: no weekly occurrence starts after the UNTIL date. +UNTIL is an inclusive bound (RFC 5545 3.3.10), so landing exactly on it is +correct and only a later date violates the property." (dotimes (_ test-calendar-sync-property-trials) (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) (until-days (+ 14 (random 60))) - ;; UNTIL must be date-only (3 elements) for calendar-sync--before-date-p (until-date (test-calendar-sync-time-date-only until-days)) (weekdays (test-calendar-sync-random-weekday-subset)) (base-event (list :summary "Until Test" :start start-date)) @@ -108,7 +136,7 @@ For any COUNT value N, expansion never produces more than N occurrences." (occurrences (calendar-sync--expand-weekly base-event rrule range))) (dolist (occ occurrences) (let ((occ-start (plist-get occ :start))) - (should (calendar-sync--before-date-p + (should (calendar-sync--date-on-or-before-p (list (nth 0 occ-start) (nth 1 occ-start) (nth 2 occ-start)) until-date))))))) diff --git a/tests/test-calendar-sync.el b/tests/test-calendar-sync.el index f562cfc6..8a7c2549 100644 --- a/tests/test-calendar-sync.el +++ b/tests/test-calendar-sync.el @@ -713,5 +713,50 @@ Valid events should be parsed, invalid ones skipped." (should-not (and org-content (string-match-p "OutOfRangeEvent" org-content))))) +;;; calendar-sync--sync-timer-function — hourly-timer body hygiene + +(ert-deftest test-calendar-sync-timer-function-does-not-propagate-a-signal () + "Error: a signal in the timer body is caught, not propagated. +The function runs from an hourly `run-at-time' timer. An unguarded signal +in the timezone check or the sync fan-out would error on every tick — the +same error, once an hour, forever. It must swallow-and-log instead." + (cl-letf (((symbol-function 'calendar-sync--timezone-changed-p) + (lambda (&rest _) (error "boom from the timezone check"))) + ((symbol-function 'calendar-sync--sync-all-calendars) #'ignore) + ((symbol-function 'calendar-sync--log-silently) #'ignore)) + ;; Must return normally rather than signal. + (should (progn (calendar-sync--sync-timer-function) t)))) + +(ert-deftest test-calendar-sync-timer-function-signal-in-sync-is-caught () + "Error: a signal from the sync fan-out is also caught, not propagated." + (cl-letf (((symbol-function 'calendar-sync--timezone-changed-p) #'ignore) + ((symbol-function 'calendar-sync--sync-all-calendars) + (lambda (&rest _) (error "boom from sync-all"))) + ((symbol-function 'calendar-sync--log-silently) #'ignore)) + (should (progn (calendar-sync--sync-timer-function) t)))) + +(ert-deftest test-calendar-sync-timer-function-timezone-change-is-not-echoed () + "Normal: a detected timezone change is logged silently, not echoed. +An hourly timer that calls `message' spams the echo area; the notice belongs +in the silent log like the module's other timer-path notices." + (let (silent-logged echoed) + (cl-letf (((symbol-function 'calendar-sync--timezone-changed-p) + (lambda (&rest _) t)) + ((symbol-function 'calendar-sync--format-timezone-offset) + (lambda (&rest _) "UTC+0")) + ((symbol-function 'calendar-sync--current-timezone-offset) + (lambda (&rest _) 0)) + ((symbol-function 'calendar-sync--sync-all-calendars) #'ignore) + ((symbol-function 'calendar-sync--log-silently) + (lambda (fmt &rest _) (when (string-match-p "Timezone" fmt) + (setq silent-logged t)))) + ((symbol-function 'message) + (lambda (fmt &rest _) (when (and (stringp fmt) + (string-match-p "Timezone" fmt)) + (setq echoed t))))) + (calendar-sync--sync-timer-function) + (should silent-logged) + (should-not echoed)))) + (provide 'test-calendar-sync) ;;; test-calendar-sync.el ends here diff --git a/tests/test-calibredb-epub-config--epub-mode.el b/tests/test-calibredb-epub-config--epub-mode.el new file mode 100644 index 00000000..a65bdabf --- /dev/null +++ b/tests/test-calibredb-epub-config--epub-mode.el @@ -0,0 +1,70 @@ +;;; test-calibredb-epub-config--epub-mode.el --- Tests for epub mode resolution -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests that .epub files reach nov-mode through `auto-mode-alist' alone, with +;; no advice on `set-auto-mode'. +;; +;; Background: the module used to carry an :around advice on `set-auto-mode' +;; forcing nov-mode for .epub, added to keep `magic-fallback-mode-alist' from +;; opening the zip container in archive-mode. It was never needed. +;; `set-auto-mode' consults `auto-mode-alist' before `magic-fallback-mode-alist', +;; and nov's use-package :mode registers "\\.epub\\'" there, so the alist +;; already won. Verified live on the daemon: a real zip-format .epub opened in +;; nov-mode both with the advice and with it removed. +;; +;; The advice was not free. `set-auto-mode' runs on every file visit, so the +;; advice put a redundant frame and an extra failure surface on the path for +;; every file of every type. +;; +;; The second test is a regression guard: it fails if the advice is ever +;; reinstated, which is the mistake this cleanup exists to prevent. +;; +;; Test organization: +;; - Normal Cases: .epub resolves to nov-mode; no advice on set-auto-mode +;; - Boundary Cases: a path merely containing "epub", and a bare "epub" name +;; - Error Cases: an unrelated extension does not resolve to nov-mode +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calibredb-epub-config) + +(defun test-epub-mode--resolve (filename) + "Return the major mode `auto-mode-alist' assigns to FILENAME." + (assoc-default filename auto-mode-alist 'string-match)) + +;;; Normal Cases + +(ert-deftest test-calibredb-epub-config-epub-resolves-to-nov-mode () + "Normal: auto-mode-alist maps a .epub file to nov-mode on its own." + (should (eq 'nov-mode (test-epub-mode--resolve "book.epub")))) + +(ert-deftest test-calibredb-epub-config-no-set-auto-mode-advice () + "Normal: nothing advises set-auto-mode to force nov-mode. +Regression guard. auto-mode-alist already wins over +magic-fallback-mode-alist, so an advice here would be redundant work on +every file visit." + (should-not (advice-member-p 'cj/force-nov-mode-for-epub 'set-auto-mode)) + (should-not (fboundp 'cj/force-nov-mode-for-epub))) + +;;; Boundary Cases + +(ert-deftest test-calibredb-epub-config-epub-in-directory-name () + "Boundary: the extension anchors at the end, so a directory named epub +does not by itself select nov-mode." + (should-not (eq 'nov-mode (test-epub-mode--resolve "/home/user/epub/notes.txt")))) + +(ert-deftest test-calibredb-epub-config-epub-with-path () + "Boundary: a full path with directories still resolves on the extension." + (should (eq 'nov-mode (test-epub-mode--resolve "/home/user/books/a b.epub")))) + +;;; Error Cases + +(ert-deftest test-calibredb-epub-config-other-extension-not-nov () + "Error: an unrelated extension must not resolve to nov-mode." + (should-not (eq 'nov-mode (test-epub-mode--resolve "archive.zip"))) + (should-not (eq 'nov-mode (test-epub-mode--resolve "notes.org")))) + +(provide 'test-calibredb-epub-config--epub-mode) +;;; test-calibredb-epub-config--epub-mode.el ends here diff --git a/tests/test-calibredb-epub-config.el b/tests/test-calibredb-epub-config.el index 71581d4c..7afc58f3 100644 --- a/tests/test-calibredb-epub-config.el +++ b/tests/test-calibredb-epub-config.el @@ -285,57 +285,6 @@ so the search buffer rebuilds against the now-unfiltered set." (cj/calibredb-clear-filters)) (should (equal "" passed)))) -;;; --------------------------- cj/force-nov-mode-for-epub --------------------- - -(ert-deftest test-calibredb-epub-force-nov-mode-on-epub-calls-nov-mode () - "Normal: a .epub buffer with nov-mode bound dispatches to `nov-mode' and -does not fall through to the original mode dispatcher." - (skip-unless (fboundp 'nov-mode)) - (let (orig-called nov-called) - (cl-letf (((symbol-function 'nov-mode) - (lambda () (setq nov-called t)))) - (with-temp-buffer - (setq buffer-file-name "/tmp/sample.epub") - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t))))) - (should nov-called) - (should-not orig-called))) - -(ert-deftest test-calibredb-epub-force-nov-mode-passes-through-non-epub () - "Boundary: a non-epub buffer falls through to the original mode dispatcher." - (let (orig-called) - (with-temp-buffer - (setq buffer-file-name "/tmp/sample.txt") - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t)))) - (should orig-called))) - -(ert-deftest test-calibredb-epub-force-nov-mode-passes-through-no-filename () - "Boundary: a buffer with no associated filename falls through to the -original mode dispatcher." - (let (orig-called) - (with-temp-buffer - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t)))) - (should orig-called))) - -(ert-deftest test-calibredb-epub-force-nov-mode-passes-through-when-nov-missing () - "Error: a .epub buffer falls through to the original dispatcher when nov-mode -is not defined (the require failed and there is nothing to dispatch to)." - (let ((saved (and (fboundp 'nov-mode) (symbol-function 'nov-mode))) - orig-called) - (when saved (fmakunbound 'nov-mode)) - (unwind-protect - (cl-letf (((symbol-function 'require) - ;; Pretend the (require 'nov nil t) call fails too. - (lambda (&rest _) nil))) - (with-temp-buffer - (setq buffer-file-name "/tmp/sample.epub") - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t))))) - (when saved (fset 'nov-mode saved))) - (should orig-called))) - ;;; ---------------------------- cj/nov--metadata-get -------------------------- (ert-deftest test-calibredb-epub-metadata-get-symbol-key () diff --git a/tests/test-custom-comments-comment-padded-divider.el b/tests/test-custom-comments-comment-padded-divider.el index d4c18905..9f2b4fd7 100644 --- a/tests/test-custom-comments-comment-padded-divider.el +++ b/tests/test-custom-comments-comment-padded-divider.el @@ -246,5 +246,23 @@ Returns the buffer string for assertions." ;; Should include comment-end (should (string-match-p "\\*/" result)))) +;;; Rendered width honors LENGTH exactly + +(ert-deftest test-padded-divider-width-matches-length-exactly () + "Normal: each decoration line renders exactly LENGTH wide. +available-width forgot the doubled semicolon (elisp) and the space after +comment-start that the emit path adds, so dividers rendered LENGTH+2 +(elisp) or LENGTH+1 wide, contradicting the docstring." + ;; elisp: lone ";" doubles to ";;" plus a space + (let* ((result (test-padded-divider-at-column 0 ";" "" "-" "x" 40 1)) + (lines (split-string result "\n" t))) + (should (= 40 (length (car lines)))) + (should (= 40 (length (car (last lines)))))) + ;; c-style with an end delimiter and no doubling + (let* ((result (test-padded-divider-at-column 0 "/*" "*/" "-" "x" 40 1)) + (lines (split-string result "\n" t))) + (should (= 40 (length (car lines)))) + (should (= 40 (length (car (last lines))))))) + (provide 'test-custom-comments-comment-padded-divider) ;;; test-custom-comments-comment-padded-divider.el ends here diff --git a/tests/test-custom-comments-public-wrappers.el b/tests/test-custom-comments-public-wrappers.el index 42842649..2eda9d94 100644 --- a/tests/test-custom-comments-public-wrappers.el +++ b/tests/test-custom-comments-public-wrappers.el @@ -188,5 +188,30 @@ text via `read-from-minibuffer'." (cj/comment-block-banner) (should (string-match-p "Banner" (buffer-string))))) +;;; cj/--comment-read-syntax — the shared comment-syntax resolution + +(ert-deftest test-comment-read-syntax-uses-buffer-syntax () + "Normal: a buffer with comment syntax resolves without prompting." + (with-temp-buffer + (setq-local comment-start ";") + (setq-local comment-end "") + (cl-letf (((symbol-function 'read-string) + (lambda (&rest _) (error "should not prompt")))) + (should (equal (cj/--comment-read-syntax) '(";" . "")))))) + +(ert-deftest test-comment-read-syntax-nil-end-falls-back-to-empty () + "Boundary: a nil comment-end resolves to the empty string." + (with-temp-buffer + (setq-local comment-start "#") + (setq-local comment-end nil) + (should (equal (cj/--comment-read-syntax) '("#" . ""))))) + +(ert-deftest test-comment-read-syntax-prompts-when-unset () + "Error: no buffer comment-start falls back to the prompt." + (with-temp-buffer + (setq-local comment-start nil) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "//"))) + (should (equal (car (cj/--comment-read-syntax)) "//"))))) + (provide 'test-custom-comments-public-wrappers) ;;; test-custom-comments-public-wrappers.el ends here diff --git a/tests/test-dashboard-config.el b/tests/test-dashboard-config.el index 2dbcd4f4..3a48ee56 100644 --- a/tests/test-dashboard-config.el +++ b/tests/test-dashboard-config.el @@ -56,5 +56,15 @@ start at the top. Without `set-window-start', batch redisplay leaves (when (buffer-live-p dash) (kill-buffer dash))))) +(ert-deftest test-dashboard-config-bookmark-override-deferred-to-package-load () + "Normal: the bookmarks override is defined exactly when dashboard-widgets is. +A bare top-level defun would exist even without the package (and be +clobbered when the package loads); the deferred registration means the +function tracks the package's own load state. Holds in both runners: +the hook env loads dashboard, the make-test env can't." + (if (featurep 'dashboard-widgets) + (should (fboundp 'dashboard-insert-bookmarks)) + (should-not (fboundp 'dashboard-insert-bookmarks)))) + (provide 'test-dashboard-config) ;;; test-dashboard-config.el ends here diff --git a/tests/test-dev-fkeys--f4-clean-rebuild-impl.el b/tests/test-dev-fkeys--f4-clean-rebuild-impl.el index 27c7c56a..bed51d79 100644 --- a/tests/test-dev-fkeys--f4-clean-rebuild-impl.el +++ b/tests/test-dev-fkeys--f4-clean-rebuild-impl.el @@ -3,7 +3,11 @@ ;;; Commentary: ;; Tests for the "Clean + Rebuild" action handler. Runs the heuristic clean ;; command via `compile' from the project root, then chains -;; `projectile-compile-project' on success via the one-shot finish hook. +;; `projectile-compile-project' on success via a one-shot finish hook +;; installed buffer-locally in the compilation buffer `compile' returns. +;; The global `compilation-finish-functions' is never touched, so a quit +;; before the compile starts or an unrelated concurrent compile can never +;; fire the chained rebuild. ;;; Code: @@ -24,6 +28,18 @@ Bind the dir path to ROOT in BODY. Cleans up on exit." ,@body) (delete-directory root t)))) +(defmacro test-dev-fkeys-cr--with-compilation-buffer (buf &rest body) + "Run BODY with BUF bound to a temp buffer standing in for a compilation buffer." + (declare (indent 1)) + `(let ((,buf (generate-new-buffer " *test-compilation*"))) + (unwind-protect + (progn ,@body) + (kill-buffer ,buf)))) + +(defun test-dev-fkeys-cr--local-hooks (buf) + "Return the buffer-local finish hooks of BUF, without the t marker." + (remq t (buffer-local-value 'compilation-finish-functions buf))) + ;;; Normal Cases (ert-deftest test-dev-fkeys-clean-rebuild-impl-runs-derived-clean-cmd () @@ -34,48 +50,50 @@ Components integrated: - `cj/--f4-clean-rebuild-impl' (unit under test) - `cj/--f4-derive-clean-cmd' (real) - `compile' (MOCKED — captures the command string) -- `projectile-compile-project' (MOCKED — no-op) -- `compilation-finish-functions' (real, scoped via let)" +- `projectile-compile-project' (MOCKED — no-op)" (test-dev-fkeys-cr--with-project '("Makefile") - (let ((compile-calls nil) - (compilation-finish-functions nil)) + (let ((compile-calls nil)) (cl-letf (((symbol-function 'compile) - (lambda (cmd) (push cmd compile-calls))) + (lambda (cmd) (push cmd compile-calls) nil)) ((symbol-function 'projectile-compile-project) (lambda (_arg) nil))) (cj/--f4-clean-rebuild-impl root) (should (equal compile-calls '("make clean"))))))) -(ert-deftest test-dev-fkeys-clean-rebuild-impl-installs-finish-hook () - "Normal: handler installs exactly one hook in `compilation-finish-functions'." +(ert-deftest test-dev-fkeys-clean-rebuild-impl-installs-hook-in-compilation-buffer () + "Normal: the one-shot hook lands buffer-locally in the buffer `compile' +returns; the global `compilation-finish-functions' stays untouched." (test-dev-fkeys-cr--with-project '("go.mod") - (let ((compilation-finish-functions nil)) - (cl-letf (((symbol-function 'compile) (lambda (_cmd) nil)) - ((symbol-function 'projectile-compile-project) - (lambda (_arg) nil))) - (cj/--f4-clean-rebuild-impl root) - (should (= (length compilation-finish-functions) 1)))))) + (test-dev-fkeys-cr--with-compilation-buffer buf + (let ((compilation-finish-functions nil)) + (cl-letf (((symbol-function 'compile) (lambda (_cmd) buf)) + ((symbol-function 'projectile-compile-project) + (lambda (_arg) nil))) + (cj/--f4-clean-rebuild-impl root) + (should (null compilation-finish-functions)) + (should (= 1 (length (test-dev-fkeys-cr--local-hooks buf))))))))) (ert-deftest test-dev-fkeys-clean-rebuild-impl-hook-runs-projectile-compile-on-success () - "Normal: when the clean step finishes successfully, the installed hook + "Normal: when the clean step finishes successfully, the buffer-local hook calls `projectile-compile-project' to do the rebuild." (test-dev-fkeys-cr--with-project '("Cargo.toml") - (let ((compile-calls 0) - (compilation-finish-functions nil)) - (cl-letf (((symbol-function 'compile) (lambda (_cmd) nil)) - ((symbol-function 'projectile-compile-project) - (lambda (_arg) (cl-incf compile-calls)))) - (cj/--f4-clean-rebuild-impl root) - (run-hook-with-args 'compilation-finish-functions nil "finished\n") - (should (= compile-calls 1)))))) + (test-dev-fkeys-cr--with-compilation-buffer buf + (let ((compile-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'compile) (lambda (_cmd) buf)) + ((symbol-function 'projectile-compile-project) + (lambda (_arg) (cl-incf compile-calls)))) + (cj/--f4-clean-rebuild-impl root) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions buf "finished\n")) + (should (= compile-calls 1))))))) (ert-deftest test-dev-fkeys-clean-rebuild-impl-runs-clean-from-project-root () "Normal: the clean compile runs with default-directory bound to ROOT." (test-dev-fkeys-cr--with-project '("Eask") - (let ((seen-dir nil) - (compilation-finish-functions nil)) + (let ((seen-dir nil)) (cl-letf (((symbol-function 'compile) - (lambda (_cmd) (setq seen-dir default-directory))) + (lambda (_cmd) (setq seen-dir default-directory) nil)) ((symbol-function 'projectile-compile-project) (lambda (_arg) nil))) (cj/--f4-clean-rebuild-impl root) @@ -87,14 +105,28 @@ calls `projectile-compile-project' to do the rebuild." (ert-deftest test-dev-fkeys-clean-rebuild-impl-hook-skips-rebuild-on-failure () "Boundary: when the clean step fails, projectile-compile-project does not run." (test-dev-fkeys-cr--with-project '("Makefile") - (let ((compile-calls 0) - (compilation-finish-functions nil)) + (test-dev-fkeys-cr--with-compilation-buffer buf + (let ((compile-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'compile) (lambda (_cmd) buf)) + ((symbol-function 'projectile-compile-project) + (lambda (_arg) (cl-incf compile-calls)))) + (cj/--f4-clean-rebuild-impl root) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions + buf "exited abnormally\n")) + (should (= compile-calls 0))))))) + +(ert-deftest test-dev-fkeys-clean-rebuild-impl-dead-compile-buffer-no-global-hook () + "Boundary: when `compile' returns no live buffer, nothing is installed +anywhere — the global hook list stays empty." + (test-dev-fkeys-cr--with-project '("Makefile") + (let ((compilation-finish-functions nil)) (cl-letf (((symbol-function 'compile) (lambda (_cmd) nil)) ((symbol-function 'projectile-compile-project) - (lambda (_arg) (cl-incf compile-calls)))) + (lambda (_arg) nil))) (cj/--f4-clean-rebuild-impl root) - (run-hook-with-args 'compilation-finish-functions nil "exited abnormally\n") - (should (= compile-calls 0)))))) + (should (null compilation-finish-functions)))))) ;;; Error Cases diff --git a/tests/test-dev-fkeys--f4-compile-and-run-impl.el b/tests/test-dev-fkeys--f4-compile-and-run-impl.el index d59a6cd6..34e5bdf3 100644 --- a/tests/test-dev-fkeys--f4-compile-and-run-impl.el +++ b/tests/test-dev-fkeys--f4-compile-and-run-impl.el @@ -2,8 +2,11 @@ ;;; Commentary: ;; Tests for the "Compile + Run" action handler. After kicking off the -;; compile, attaches a one-shot `compilation-finish-functions' hook that -;; runs the project on success. +;; compile, attaches a one-shot finish hook buffer-locally in the +;; compilation buffer projectile returns, so the global +;; `compilation-finish-functions' is never touched. A quit at +;; projectile's compile prompt therefore can never leave an armed hook +;; that a later unrelated compile would fire. ;;; Code: @@ -12,6 +15,14 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'dev-fkeys) +(defmacro test-dev-fkeys-car--with-buffer (buf &rest body) + "Run BODY with BUF bound to a temp buffer standing in for a compilation buffer." + (declare (indent 1)) + `(let ((,buf (generate-new-buffer " *test-compilation*"))) + (unwind-protect + (progn ,@body) + (kill-buffer ,buf)))) + ;;; Normal Cases (ert-deftest test-dev-fkeys-compile-and-run-impl-invokes-projectile-compile () @@ -19,57 +30,77 @@ Components integrated: - `cj/--f4-compile-and-run-impl' (unit under test) -- `projectile-compile-project' (MOCKED via cl-letf) -- `compilation-finish-functions' (real, scoped via let)" - (let ((compile-calls 0) - (compilation-finish-functions nil)) +- `projectile-compile-project' (MOCKED via cl-letf)" + (let ((compile-calls 0)) (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) (cl-incf compile-calls)))) + (lambda (_arg) (cl-incf compile-calls) nil))) (cj/--f4-compile-and-run-impl) (should (= compile-calls 1))))) -(ert-deftest test-dev-fkeys-compile-and-run-impl-installs-finish-hook () - "Normal: handler installs exactly one hook in `compilation-finish-functions'." - (let ((compilation-finish-functions nil)) - (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) nil))) - (cj/--f4-compile-and-run-impl) - (should (= (length compilation-finish-functions) 1))))) +(ert-deftest test-dev-fkeys-compile-and-run-impl-installs-hook-in-compilation-buffer () + "Normal: the one-shot hook lands buffer-locally in the compilation buffer; +the global `compilation-finish-functions' stays untouched." + (test-dev-fkeys-car--with-buffer buf + (let ((compilation-finish-functions nil)) + (cl-letf (((symbol-function 'projectile-compile-project) + (lambda (_arg) buf))) + (cj/--f4-compile-and-run-impl) + (should (null compilation-finish-functions)) + (should (= 1 (length (remq t (buffer-local-value + 'compilation-finish-functions buf))))))))) (ert-deftest test-dev-fkeys-compile-and-run-impl-hook-runs-projectile-run-on-success () - "Normal: when the compile finishes successfully, the installed hook calls -`projectile-run-project'. + "Normal: when the compile finishes successfully, the buffer-local hook +calls `projectile-run-project'. Components integrated: - `cj/--f4-compile-and-run-impl' (unit under test) -- `projectile-compile-project' (MOCKED — no-op) +- `projectile-compile-project' (MOCKED — returns the compilation buffer) - `projectile-run-project' (MOCKED — counts calls) -- `compilation-finish-functions' (real) +- `compilation-finish-functions' (real, buffer-local) - `run-hook-with-args' (real — simulates compile.el firing the hook)" - (let ((run-calls 0) - (compilation-finish-functions nil)) - (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) nil)) - ((symbol-function 'projectile-run-project) - (lambda (_arg) (cl-incf run-calls)))) - (cj/--f4-compile-and-run-impl) - (run-hook-with-args 'compilation-finish-functions nil "finished\n") - (should (= run-calls 1))))) + (test-dev-fkeys-car--with-buffer buf + (let ((run-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'projectile-compile-project) + (lambda (_arg) buf)) + ((symbol-function 'projectile-run-project) + (lambda (_arg) (cl-incf run-calls)))) + (cj/--f4-compile-and-run-impl) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions buf "finished\n")) + (should (= run-calls 1)))))) ;;; Boundary Cases (ert-deftest test-dev-fkeys-compile-and-run-impl-hook-skips-projectile-run-on-failure () "Boundary: when the compile fails, projectile-run-project must not run. The hook still self-removes (covered in the make-once-hook tests)." - (let ((run-calls 0) - (compilation-finish-functions nil)) + (test-dev-fkeys-car--with-buffer buf + (let ((run-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'projectile-compile-project) + (lambda (_arg) buf)) + ((symbol-function 'projectile-run-project) + (lambda (_arg) (cl-incf run-calls)))) + (cj/--f4-compile-and-run-impl) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions + buf "exited abnormally\n")) + (should (= run-calls 0)))))) + +(ert-deftest test-dev-fkeys-compile-and-run-impl-quit-leaves-no-global-hook () + "Boundary: a quit at projectile's prompt leaves no armed hook anywhere. +This is the regression the buffer-local install exists to prevent: the +old shape armed a global hook before the prompt, so C-g left it live and +the next unrelated compile fired the chained run." + (let ((compilation-finish-functions nil)) (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) nil)) - ((symbol-function 'projectile-run-project) - (lambda (_arg) (cl-incf run-calls)))) - (cj/--f4-compile-and-run-impl) - (run-hook-with-args 'compilation-finish-functions nil "exited abnormally\n") - (should (= run-calls 0))))) + (lambda (_arg) (signal 'quit nil)))) + (condition-case nil + (cj/--f4-compile-and-run-impl) + (quit nil)) + (should (null compilation-finish-functions))))) (provide 'test-dev-fkeys--f4-compile-and-run-impl) ;;; test-dev-fkeys--f4-compile-and-run-impl.el ends here diff --git a/tests/test-dev-fkeys--f4-make-once-hook.el b/tests/test-dev-fkeys--f4-make-once-hook.el index b6c71dd7..4fc84e63 100644 --- a/tests/test-dev-fkeys--f4-make-once-hook.el +++ b/tests/test-dev-fkeys--f4-make-once-hook.el @@ -95,6 +95,21 @@ hook exactly once per compile, so the practical contract is one-shot." (funcall hook nil "interrupt\n")) (should (= called 0)))) +(ert-deftest test-dev-fkeys-make-once-hook-removes-itself-buffer-locally () + "Boundary: a hook installed buffer-locally removes its local entry when +run in that buffer — the shape used by the F4 chained-compile handlers." + (let ((buf (generate-new-buffer " *test-once-hook*")) + (called 0)) + (unwind-protect + (let ((hook (cj/--f4-make-once-hook (lambda () (cl-incf called))))) + (with-current-buffer buf + (add-hook 'compilation-finish-functions hook nil t) + (funcall hook buf "finished\n") + (should-not (memq hook (buffer-local-value + 'compilation-finish-functions buf)))) + (should (= called 1))) + (kill-buffer buf)))) + ;;; Error Cases (ert-deftest test-dev-fkeys-make-once-hook-then-fn-error-still-removes-hook () 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 d7b6a059..59d0ba42 100644 --- a/tests/test-dev-fkeys--f6-test-runner-cmd-for.el +++ b/tests/test-dev-fkeys--f6-test-runner-cmd-for.el @@ -138,10 +138,15 @@ rather than a silent nil that F6's outer wrapper interprets as 'typescript t "src/foo.test.ts" "foo" "src") "npx --no-install vitest src/foo.test.ts")))) -(ert-deftest test-dev-fkeys-f6-cmd-for-javascript-returns-nil () - "Error: JavaScript is punted for v1 and returns nil." - (should (null (cj/--f6-test-runner-cmd-for - 'javascript t "src/foo.test.js" "foo" "src")))) +(ert-deftest test-dev-fkeys-f6-cmd-for-javascript-uses-npx-runner () + "Normal: javascript gets the same npx runner command as typescript. +The language detector classifies js/jsx and the test-file detector +recognizes JS test files, but the dispatch had no javascript arm, so +C-F6 on a JS test errored even though the npx path would run it." + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil))) + (should (equal (cj/--f6-test-runner-cmd-for + 'javascript t "src/foo.test.js" "foo" "src") + "npx --no-install jest src/foo.test.js")))) (ert-deftest test-dev-fkeys-f6-cmd-for-unknown-returns-nil () "Error: an unknown language returns nil." diff --git a/tests/test-diff-config--ediff-options.el b/tests/test-diff-config--ediff-options.el new file mode 100644 index 00000000..a43637d9 --- /dev/null +++ b/tests/test-diff-config--ediff-options.el @@ -0,0 +1,27 @@ +;;; test-diff-config--ediff-options.el --- Tests for ediff diff options -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins the removal of the global "-w" default for `ediff-diff-options'. +;; With "-w", every ediff session ignores ALL whitespace, so +;; indentation-only changes (significant in Python, Makefiles, YAML) +;; compare as identical. Whitespace-ignoring is a per-session toggle +;; (ediff's `##'), not a global default. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'diff-config) + +;;; Normal Cases + +(ert-deftest test-diff-config-ediff-options-no-global-whitespace-ignore () + "Normal: after ediff loads, no global -w sits in ediff-diff-options. +The use-package :custom values apply when the deferred package loads, +so the assertion must run with ediff actually loaded." + (require 'ediff) + (should (not (string-match-p "-w" (or ediff-diff-options ""))))) + +(provide 'test-diff-config--ediff-options) +;;; test-diff-config--ediff-options.el ends here diff --git a/tests/test-dirvish-config-runtime-requires.el b/tests/test-dirvish-config-runtime-requires.el index 34fb67ac..ca94e4b5 100644 --- a/tests/test-dirvish-config-runtime-requires.el +++ b/tests/test-dirvish-config-runtime-requires.el @@ -3,15 +3,13 @@ ;;; Commentary: ;; dirvish-config.el builds `dirvish-quick-access-entries' from `code-dir', ;; `music-dir', `pix-dir' (and friends) at load time and binds keys to -;; `cj/xdg-open' / `cj/open-file-with-command', so it depends on user-constants -;; and system-utils at runtime. Those were declared with `eval-when-compile', -;; which leaves the compiled module without the requires at load — fragile -;; under init order. This is a dependency-contract smoke test: requiring -;; dirvish-config in isolation must pull both features in, so it fails if the -;; requires are dropped entirely. (It can't catch a downgrade back to -;; `eval-when-compile', since that form still runs when the file loads as -;; source, which the test harness does — that regression is guarded by keeping -;; the plain requires in review, not by this test.) +;; `cj/xdg-open' (external-open) and `cj/open-file-with-command' +;; (system-utils), so it depends on user-constants, system-utils, and +;; external-open at runtime. This is a dependency-contract smoke test: +;; requiring dirvish-config in isolation must pull those features in, so it +;; fails if the requires are dropped entirely. Run it with `make test-file' +;; for a clean signal: in the full suite another file may already have loaded +;; external-open, masking a regression here. ;;; Code: @@ -26,5 +24,13 @@ "Normal: requiring dirvish-config pulls in system-utils at runtime." (should (featurep 'system-utils))) +(ert-deftest test-dirvish-config-loads-external-open () + "Normal: requiring dirvish-config pulls in external-open at runtime. +The keys `o' and the OS-handler fallback call `cj/xdg-open', which lives +in external-open; without the require the binding works only when init +order happens to load external-open first." + (should (featurep 'external-open)) + (should (fboundp 'cj/xdg-open))) + (provide 'test-dirvish-config-runtime-requires) ;;; test-dirvish-config-runtime-requires.el ends here diff --git a/tests/test-dwim-shell-config-runtime-requires.el b/tests/test-dwim-shell-config-runtime-requires.el new file mode 100644 index 00000000..ab53e7d4 --- /dev/null +++ b/tests/test-dwim-shell-config-runtime-requires.el @@ -0,0 +1,24 @@ +;;; test-dwim-shell-config-runtime-requires.el --- dwim-shell-config declares its deps -*- lexical-binding: t; -*- + +;;; Commentary: +;; dwim-shell-config.el calls `cj/xdg-open' (external-open) to open a +;; conversion's output file, but declared it only with `declare-function' +;; and never required external-open. The binding works at runtime only +;; because init.el happens to load external-open first — fragile under init +;; order, and the "Direct test load: yes" header claims otherwise. This is +;; a dependency-contract smoke test: requiring dwim-shell-config in isolation +;; must pull external-open in. Run with `make test-file' for a clean signal; +;; in the full suite another file may already have loaded external-open. + +;;; Code: + +(require 'ert) +(require 'dwim-shell-config) + +(ert-deftest test-dwim-shell-config-loads-external-open () + "Normal: requiring dwim-shell-config pulls in external-open at runtime." + (should (featurep 'external-open)) + (should (fboundp 'cj/xdg-open))) + +(provide 'test-dwim-shell-config-runtime-requires) +;;; test-dwim-shell-config-runtime-requires.el ends here diff --git a/tests/test-elfeed-config-helpers.el b/tests/test-elfeed-config-helpers.el index 16cbb744..95a98e83 100644 --- a/tests/test-elfeed-config-helpers.el +++ b/tests/test-elfeed-config-helpers.el @@ -1,10 +1,7 @@ ;;; test-elfeed-config-helpers.el --- Tests for elfeed stream/process helpers -*- lexical-binding: t; -*- ;;; Commentary: -;; Coverage for two elfeed-config helpers that were untested: -;; - cj/extract-stream-url: runs yt-dlp -g to resolve a direct stream URL, -;; returning the URL, nil on non-URL / nonzero exit, or signalling when -;; yt-dlp is absent. +;; Coverage for the elfeed-config entry-processing helper: ;; - cj/elfeed-process-entries: applies an action to each selected entry, ;; marking them read; errors when nothing is selected, skips entries with ;; no link, and (by default) catches per-entry action errors. @@ -34,40 +31,6 @@ (require 'elfeed-config) (require 'elfeed nil t) -;;; cj/extract-stream-url - -(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 &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) - (insert "https://stream.example/abc\n") 0))) - (should (equal "https://stream.example/abc" - (cj/extract-stream-url "https://youtube.com/watch?v=x" "best"))))) - -(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 (_ &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))) - (should (null (cj/extract-stream-url "u" nil))))) - -(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 (_ &rest _) "/usr/bin/yt-dlp")) - ((symbol-function 'cj/log-silently) #'ignore) - ((symbol-function 'call-process) - (lambda (_p _i _d _disp &rest _) (insert "boom") 1))) - (should (null (cj/extract-stream-url "u" nil))))) - -(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 (_ &rest _) nil))) - (should-error (cj/extract-stream-url "u" "best") :type 'error))) - ;;; cj/elfeed-process-entries (defun cj/test--elfeed-entry (link) diff --git a/tests/test-external-open--open-with-argv.el b/tests/test-external-open--open-with-argv.el new file mode 100644 index 00000000..27a7e811 --- /dev/null +++ b/tests/test-external-open--open-with-argv.el @@ -0,0 +1,59 @@ +;;; test-external-open--open-with-argv.el --- Tests for cj/--open-with-argv -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for cj/--open-with-argv, the pure builder that turns the +;; user-typed "open with" command plus a file path into an argv list. +;; The argv shape is the hardening: the file is one list element, so paths +;; with spaces or shell metacharacters never meet a shell. +;; +;; Test organization: +;; - Normal Cases: bare program, program with args, quoted argument +;; - Boundary Cases: file with spaces and metacharacters stays one element +;; - Error Cases: empty and whitespace-only commands +;; +;;; Code: + +(require 'ert) +(require 'external-open) + +;;; Normal Cases + +(ert-deftest test-external-open--open-with-argv-normal-bare-program () + "Normal: a bare program name yields (PROGRAM FILE)." + (should (equal (cj/--open-with-argv "vlc" "/tmp/foo.mp4") + '("vlc" "/tmp/foo.mp4")))) + +(ert-deftest test-external-open--open-with-argv-normal-program-with-args () + "Normal: a command typed with arguments splits into argv words." + (should (equal (cj/--open-with-argv "mpv --fs --loop" "/tmp/foo.mp4") + '("mpv" "--fs" "--loop" "/tmp/foo.mp4")))) + +(ert-deftest test-external-open--open-with-argv-normal-quoted-arg-survives () + "Normal: a double-quoted argument stays one word." + (should (equal (cj/--open-with-argv "player \"two words\"" "/tmp/foo.mp4") + '("player" "two words" "/tmp/foo.mp4")))) + +;;; Boundary Cases + +(ert-deftest test-external-open--open-with-argv-boundary-file-with-spaces () + "Boundary: a path with spaces is one argv element, untouched." + (let ((file "/tmp/my file (draft).mp4")) + (should (equal (car (last (cj/--open-with-argv "vlc" file))) file)))) + +(ert-deftest test-external-open--open-with-argv-boundary-file-with-metacharacters () + "Boundary: shell metacharacters in the path arrive verbatim." + (let ((file "/tmp/a;b&c$(d)'e.mp4")) + (should (equal (car (last (cj/--open-with-argv "vlc" file))) file)))) + +;;; Error Cases + +(ert-deftest test-external-open--open-with-argv-error-empty-command () + "Error: an empty command signals user-error." + (should-error (cj/--open-with-argv "" "/tmp/foo.mp4") :type 'user-error)) + +(ert-deftest test-external-open--open-with-argv-error-whitespace-command () + "Error: a whitespace-only command signals user-error." + (should-error (cj/--open-with-argv " " "/tmp/foo.mp4") :type 'user-error)) + +(provide 'test-external-open--open-with-argv) +;;; test-external-open--open-with-argv.el ends here diff --git a/tests/test-external-open-commands.el b/tests/test-external-open-commands.el index 3d8adc15..5cab1196 100644 --- a/tests/test-external-open-commands.el +++ b/tests/test-external-open-commands.el @@ -64,22 +64,41 @@ (should-error (cj/open-this-file-with "vlc") :type 'user-error))) (ert-deftest test-external-open-open-this-file-with-spawns-detached-process () - "Normal: posix path invokes `call-process-shell-command' with nohup + bg." - (let ((cmd nil)) + "Normal: posix path launches an argv `call-process' with DESTINATION 0." + (let ((captured nil)) (with-temp-buffer - (setq buffer-file-name "/tmp/foo.mp4") + (setq buffer-file-name "/tmp/my file.mp4") (cl-letf (((symbol-function 'env-windows-p) (lambda () nil)) - ((symbol-function 'call-process-shell-command) - (lambda (c _infile _buf &rest _) - (setq cmd c)))) - (cj/open-this-file-with "vlc")) + ((symbol-function 'executable-find) + (lambda (&rest _) "/usr/bin/vlc")) + ((symbol-function 'call-process) + (lambda (&rest args) (setq captured args) 0))) + (cj/open-this-file-with "vlc --fs")) (setq buffer-file-name nil)) - (should (string-match-p "^nohup vlc " cmd)) - (should (string-match-p "&$" cmd)) - (should (string-match-p ">/dev/null" cmd)))) + (should (equal captured '("vlc" nil 0 nil "--fs" "/tmp/my file.mp4"))))) + +(ert-deftest test-external-open-open-this-file-with-errors-missing-program () + "Error: a program not on PATH signals user-error before launching." + (with-temp-buffer + (setq buffer-file-name "/tmp/foo.mp4") + (cl-letf (((symbol-function 'env-windows-p) (lambda () nil)) + ((symbol-function 'executable-find) (lambda (&rest _) nil))) + (should-error (cj/open-this-file-with "no-such-program") + :type 'user-error)) + (setq buffer-file-name nil))) ;;; cj/find-file-auto +(ert-deftest test-external-open-video-looping-errors-missing-program () + "Error: a missing video player gives a clear user-error, not an opaque crash. +The command fires via the find-file advice, so visiting a video on a +machine without mpv must fail with a message naming the program." + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'call-process) + (lambda (&rest _) (error "call-process should not run")))) + (should-error (cj/open-video-looping "/tmp/some-video.mp4") + :type 'user-error))) + (ert-deftest test-external-open-find-file-auto-routes-media-externally () "Normal: a non-video external extension (`.docx', in `default-open-extensions') triggers `cj/xdg-open' instead of the original diff --git a/tests/test-flyspell-and-abbrev.el b/tests/test-flyspell-and-abbrev.el index 3b494d5e..b4be6ab3 100644 --- a/tests/test-flyspell-and-abbrev.el +++ b/tests/test-flyspell-and-abbrev.el @@ -17,6 +17,7 @@ (require 'ert) (require 'cl-lib) +(require 'user-constants) ;; org-dir, read by the ispell :config below (require 'flyspell) (require 'flyspell-and-abbrev) @@ -27,6 +28,23 @@ (overlay-put o 'face 'flyspell-incorrect) o)) +;; ------------------------- org src-block skip entry --------------------------- + +(ert-deftest test-flyspell-ispell-skip-entry-matches-src-block-lines () + "Normal: the ispell skip entry matches real org src-block delimiters. +The old entry used \"#+\" (one-or-more #), which matches no real +begin_src line, so ispell spell-checked inside every org code block." + (require 'ispell) + (let ((entry (seq-find (lambda (e) + (and (consp e) (stringp (car e)) + (string-match-p "BEGIN_SRC" (car e)))) + ispell-skip-region-alist))) + (should entry) + (let ((case-fold-search t)) + (should (string-match-p (car entry) "#+BEGIN_SRC emacs-lisp")) + (should (string-match-p (car entry) "#+begin_src python")) + (should (string-match-p (cdr entry) "#+end_src"))))) + ;; ------------------------ cj/--require-spell-checker ------------------------- (ert-deftest test-flyspell-require-spell-checker-present () diff --git a/tests/test-font-config--frame-lifecycle.el b/tests/test-font-config--frame-lifecycle.el deleted file mode 100644 index 8f338b99..00000000 --- a/tests/test-font-config--frame-lifecycle.el +++ /dev/null @@ -1,75 +0,0 @@ -;;; 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-nerd-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 'nerd-icons-install-fonts) (lambda (&rest _) (setq installed t))) - ((symbol-function 'remove-hook) #'ignore)) - (cj/maybe-install-nerd-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 'nerd-icons-install-fonts) (lambda (&rest _) (setq installed t)))) - (cj/maybe-install-nerd-icons-fonts)) - (should-not installed))) - -(provide 'test-font-config--frame-lifecycle) -;;; test-font-config--frame-lifecycle.el ends here diff --git a/tests/test-font-config.el b/tests/test-font-config.el index 4df2b41a..06ea226b 100644 --- a/tests/test-font-config.el +++ b/tests/test-font-config.el @@ -4,11 +4,10 @@ ;; font-config.el is mostly top-level font/package setup. These smoke tests ;; cover the logic that should stay correct regardless of which fonts are -;; installed: the install check, and the daemon-frame font applier (env-gui-p -;; guard plus idempotency). The module :demand's fontaine and references -;; nerd-icons, so the tests skip when those packages are absent rather than -;; failing on a bare checkout. GUI and font lookups are stubbed so the run -;; stays headless. +;; installed: the install check, task-oriented Fontaine picker, persistence, +;; and emoji setup. The module :demand's fontaine and references nerd-icons, so +;; the tests skip when those packages are absent rather than failing on a bare +;; checkout. GUI and font lookups are stubbed so the run stays headless. ;;; Code: @@ -41,34 +40,32 @@ (cl-letf (((symbol-function 'find-font) (lambda (&rest _) nil))) (should (null (cj/font-installed-p "No Such Font 12345"))))) -;;; cj/apply-font-settings-to-frame +;;; cj/maybe-install-nerd-icons-fonts -(ert-deftest test-font-config-apply-font-settings-noop-without-gui () - "Boundary: on a non-GUI frame the applier does nothing and does not error." +(ert-deftest test-font-config-nerd-icons-missing-font-installs-on-gui () + "Normal: a missing Nerd Icons font is installed on a GUI frame." (skip-unless test-font-config--available) (require 'font-config) - (let ((cj/fontaine-configured-frames nil) - (applied nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) nil)) - ((symbol-function 'fontaine-set-preset) - (lambda (&rest _) (setq applied t)))) - (cj/apply-font-settings-to-frame (selected-frame)) - (should-not applied) - (should-not cj/fontaine-configured-frames)))) - -(ert-deftest test-font-config-apply-font-settings-applies-once-per-frame () - "Normal: on a GUI frame the applier sets the preset once and is idempotent." - (skip-unless test-font-config--available) - (require 'font-config) - (let ((cj/fontaine-configured-frames nil) - (calls 0)) - (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) t)) - ((symbol-function 'fontaine-set-preset) - (lambda (&rest _) (setq calls (1+ calls))))) - (cj/apply-font-settings-to-frame (selected-frame)) - (cj/apply-font-settings-to-frame (selected-frame)) - (should (= calls 1)) - (should (memq (selected-frame) cj/fontaine-configured-frames))))) + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_name) nil)) + ((symbol-function 'nerd-icons-install-fonts) + (lambda (&rest _) (setq installed t))) + ((symbol-function 'remove-hook) #'ignore)) + (cj/maybe-install-nerd-icons-fonts)) + (should installed))) + +(ert-deftest test-font-config-nerd-icons-installed-font-skips-install () + "Boundary: an installed Nerd Icons font needs no install attempt." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_name) t)) + ((symbol-function 'nerd-icons-install-fonts) + (lambda (&rest _) (setq installed t)))) + (cj/maybe-install-nerd-icons-fonts)) + (should-not installed))) ;;; cj/setup-emoji-fontset @@ -135,5 +132,206 @@ (when (get-buffer "*Available Fonts*") (kill-buffer "*Available Fonts*"))))) +;;; Fontaine workflow profiles + +(ert-deftest test-font-config-fontaine-presets-are-task-oriented () + "Normal: the picker exposes eight complete workflow destinations." + (skip-unless test-font-config--available) + (require 'font-config) + (should (equal (delq t (mapcar #'car fontaine-presets)) + '(everyday writing reading coding-xs coding-m coding-l coding-xl + presentation)))) + +(ert-deftest test-font-config-fontaine-candidates-describe-end-state () + "Normal: every profile label names its purpose, fonts, and point size." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((candidates (cj/fontaine-profile-candidates))) + (should (= (length candidates) 8)) + (should (member (nth 0 candidates) + '("Everyday — Berkeley Mono + Lexend · 13 pt" + "Everyday — Berkeley Mono + Lexend · 14 pt"))) + (should (equal (nth 1 candidates) + "Writing — Berkeley Mono + Merriweather · 14 pt")) + (should (equal (nth 2 candidates) + "Reading — Merriweather · 14 pt")) + (should (equal (nth 3 candidates) + "Coding XS — Berkeley Mono · 11 pt")) + (should (equal (nth 4 candidates) + "Coding M — Berkeley Mono · 13 pt")) + (should (equal (nth 5 candidates) + "Coding L — Berkeley Mono · 14 pt")) + (should (equal (nth 6 candidates) + "Coding XL — Berkeley Mono · 16 pt")) + (should (equal (nth 7 candidates) + "Presentation — Berkeley Mono + Lexend · 20 pt")))) + +(ert-deftest test-font-config-fontaine-candidate-round-trips-to-profile () + "Boundary: a displayed destination maps back to its Fontaine symbol." + (skip-unless test-font-config--available) + (require 'font-config) + (dolist (profile '(everyday writing reading coding-xs coding-m coding-l coding-xl + presentation)) + (let ((label (cj/fontaine-profile-label profile))) + (should (eq (cj/fontaine-profile-from-label label) profile))))) + +(ert-deftest test-font-config-fontaine-uses-one-monospace-family () + "Normal: every workflow profile uses Berkeley Mono for fixed pitch." + (skip-unless test-font-config--available) + (require 'font-config) + (dolist (profile '(everyday writing coding-xs coding-m coding-l coding-xl presentation)) + (let ((properties (fontaine--get-preset-properties profile))) + (should (equal (plist-get properties :default-family) + "BerkeleyMono Nerd Font"))))) + +(ert-deftest test-font-config-fontaine-reading-is-merriweather-only () + "Normal: Reading uses Merriweather for every primary face family." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((properties (fontaine--get-preset-properties 'reading))) + (dolist (property '(:default-family + :fixed-pitch-family + :fixed-pitch-serif-family + :variable-pitch-family)) + (should (equal (plist-get properties property) "Merriweather"))))) + +(ert-deftest test-font-config-fontaine-reading-properties-are-public () + "Normal: consumers can resolve Reading without Fontaine private functions." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((properties (cj/fontaine-profile-properties 'reading))) + (should (equal (plist-get properties :default-family) "Merriweather")) + (should (= (plist-get properties :default-height) 140)))) + +(ert-deftest test-font-config-fontaine-remaps-reading-buffer-locally () + "Normal: the local adapter applies all Reading families at an override height." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((calls nil)) + (cl-letf (((symbol-function 'face-remap-add-relative) + (lambda (face &rest properties) + (push (cons face properties) calls) + face))) + (should (equal (cj/fontaine-remap-buffer-to-profile 'reading 180) + '(default fixed-pitch fixed-pitch-serif variable-pitch)))) + (dolist (face '(default fixed-pitch fixed-pitch-serif variable-pitch)) + (should (member (list face :family "Merriweather" :height 180) + calls))))) + +(ert-deftest test-font-config-fontaine-ui-buffer-remaps-default-to-berkeley () + "Normal: minibuffer and echo buffers remap their default face to Berkeley." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((base nil)) + (cl-letf (((symbol-function 'face-remap-set-base) + (lambda (face &rest specs) (setq base (cons face specs))))) + (cj/fontaine-remap-ui-buffer)) + (should (equal base + '(default (:family "BerkeleyMono Nerd Font")))))) + +(ert-deftest test-font-config-fontaine-ui-chrome-stays-berkeley () + "Normal: Fontaine reasserts Berkeley on chrome faces and echo buffers." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((faces nil) + (remap-count 0)) + (cl-letf (((symbol-function 'facep) (lambda (_face) t)) + ((symbol-function 'set-face-attribute) + (lambda (face _frame &rest properties) + (push (cons face properties) faces))) + ((symbol-function 'get-buffer) (lambda (_name) (current-buffer))) + ((symbol-function 'cj/fontaine-remap-ui-buffer) + (lambda () (setq remap-count (1+ remap-count))))) + (cj/fontaine-keep-ui-chrome-monospace)) + (dolist (face '(mode-line mode-line-active mode-line-inactive + minibuffer-prompt)) + (should (member (list face :family "BerkeleyMono Nerd Font") faces))) + (should (= remap-count 2)))) + +(ert-deftest test-font-config-fontaine-ui-chrome-hooks-are-installed () + "Boundary: profile, theme, and minibuffer changes restore UI typography." + (skip-unless test-font-config--available) + (require 'font-config) + (should (memq 'cj/fontaine-keep-ui-chrome-monospace + fontaine-set-preset-hook)) + (should (memq 'cj/fontaine-keep-ui-chrome-monospace + enable-theme-functions)) + (should (memq 'cj/fontaine-remap-ui-buffer minibuffer-setup-hook))) + +(ert-deftest test-font-config-fontaine-unknown-label-has-no-profile () + "Error: an unknown destination label does not select a preset." + (skip-unless test-font-config--available) + (require 'font-config) + (should-not (cj/fontaine-profile-from-label "Missing profile"))) + +(ert-deftest test-font-config-fontaine-annotation-marks-current-profile () + "Normal: completion marks only the active workflow destination." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((fontaine-current-preset 'writing)) + (should (equal (cj/fontaine-profile-annotation + (cj/fontaine-profile-label 'writing)) + " current")) + (should (equal (cj/fontaine-profile-annotation + (cj/fontaine-profile-label 'coding-m)) + "")))) + +(ert-deftest test-font-config-fontaine-selector-applies-picked-profile () + "Normal: the one-prompt picker maps its complete label before applying." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((picked (cj/fontaine-profile-label 'presentation)) + (applied nil)) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _choices &rest _) picked)) + ((symbol-function 'cj/fontaine-apply-profile) + (lambda (profile) (setq applied profile)))) + (cj/fontaine-select-profile) + (should (eq applied 'presentation))))) + +(ert-deftest test-font-config-fontaine-restores-valid-profile () + "Normal: startup restores a persisted workflow profile." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-restore-latest-preset) + (lambda () 'writing))) + (should (eq (cj/fontaine-restored-or-default-profile) 'writing)))) + +(ert-deftest test-font-config-fontaine-rejects-obsolete-restored-profile () + "Boundary: an old brand or point-size preset falls back to everyday." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-restore-latest-preset) + (lambda () '13-point-font))) + (should (eq (cj/fontaine-restored-or-default-profile) 'everyday)))) + +(ert-deftest test-font-config-fontaine-has-no-per-frame-reset-hook () + "Boundary: creating a daemon frame cannot overwrite the active profile." + (skip-unless test-font-config--available) + (require 'font-config) + (should-not (memq 'cj/apply-font-settings-to-frame + server-after-make-frame-hook)) + (should-not (memq 'cj/cleanup-frame-list delete-frame-functions))) + +(ert-deftest test-font-config-fontaine-apply-records-profile-for-persistence () + "Normal: applying a profile updates Fontaine history before setting it." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((fontaine-preset-history nil) + (applied nil)) + (cl-letf (((symbol-function 'fontaine-set-preset) + (lambda (profile) (setq applied profile)))) + (cj/fontaine-apply-profile 'coding-m) + (should (eq applied 'coding-m)) + (should (equal (car fontaine-preset-history) "coding-m"))))) + +(ert-deftest test-font-config-fontaine-apply-rejects-unknown-profile () + "Error: applying an unknown workflow profile signals a user error." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-set-preset) + (lambda (_profile) (ert-fail "must not apply")))) + (should-error (cj/fontaine-apply-profile 'missing) :type 'user-error))) + (provide 'test-font-config) ;;; test-font-config.el ends here diff --git a/tests/test-help-utils--arch-wiki-search.el b/tests/test-help-utils--arch-wiki-search.el new file mode 100644 index 00000000..d02dd041 --- /dev/null +++ b/tests/test-help-utils--arch-wiki-search.el @@ -0,0 +1,124 @@ +;;; test-help-utils--arch-wiki-search.el --- Tests for the ArchWiki search guard -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for cj/--arch-wiki-topics and the cj/local-arch-wiki-search command. +;; +;; The bug: the command read "/usr/share/doc/arch-wiki/html/en" with +;; `directory-files' before checking the directory existed. On a machine +;; without arch-wiki-docs -- the exact state the command's own error text is +;; written for -- that signaled file-missing on the first line, so the friendly +;; "Is arch-wiki-docs installed?" message below it was unreachable. The user +;; got a raw Lisp error naming a path instead of the install hint. +;; +;; Two things had to change to make this testable. The directory was +;; hardcoded inside the command, so a test could only ever exercise whatever +;; the developer's own machine happened to have installed; it is now +;; `cj/arch-wiki-html-dir'. And the directory read is now the pure helper +;; cj/--arch-wiki-topics, which takes a directory and returns an alist, so the +;; interesting cases are driven with real temporary directories instead of +;; mocking `directory-files'. +;; +;; Test organization: +;; - Normal Cases: topics found and returned; the command opens the choice +;; - Boundary Cases: empty dir, single topic, a name matching no topic +;; - Error Cases: missing dir returns nil and reports the install hint +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'help-utils) + +(defmacro test-arch-wiki--with-topics (dir-var topics &rest body) + "Bind DIR-VAR to a temp dir holding TOPICS (a list of html basenames). +The directory is removed after BODY." + (declare (indent 2)) + `(let ((,dir-var (make-temp-file "arch-wiki-test" t))) + (unwind-protect + (progn + (dolist (name ,topics) + (write-region "" nil (expand-file-name (concat name ".html") ,dir-var))) + ,@body) + (delete-directory ,dir-var t)))) + +;;; Normal Cases — the pure helper + +(ert-deftest test-help-utils-arch-wiki-topics-lists-html-basenames () + "Normal: each .html file becomes a (basename . fullpath) pair." + (test-arch-wiki--with-topics dir '("Systemd" "Pacman") + (let ((topics (cj/--arch-wiki-topics dir))) + (should (equal '("Pacman" "Systemd") (sort (mapcar #'car topics) #'string<))) + (should (string-suffix-p "Systemd.html" (cdr (assoc "Systemd" topics))))))) + +(ert-deftest test-help-utils-arch-wiki-topics-ignores-non-html () + "Normal: files without the .html extension are not topics." + (test-arch-wiki--with-topics dir '("Systemd") + (write-region "" nil (expand-file-name "README.txt" dir)) + (should (equal '("Systemd") (mapcar #'car (cj/--arch-wiki-topics dir)))))) + +;;; Boundary Cases + +(ert-deftest test-help-utils-arch-wiki-topics-empty-dir-is-nil () + "Boundary: an existing but empty directory yields no topics." + (test-arch-wiki--with-topics dir '() + (should (null (cj/--arch-wiki-topics dir))))) + +(ert-deftest test-help-utils-arch-wiki-topics-single-topic () + "Boundary: one topic returns a one-element alist." + (test-arch-wiki--with-topics dir '("Systemd") + (should (= 1 (length (cj/--arch-wiki-topics dir)))))) + +;;; Error Cases — the missing-install path + +(ert-deftest test-help-utils-arch-wiki-topics-missing-dir-returns-nil () + "Error: an absent directory returns nil rather than signaling file-missing." + (let ((missing (expand-file-name "definitely-absent-arch-wiki" + temporary-file-directory))) + (should-not (file-directory-p missing)) + (should (null (cj/--arch-wiki-topics missing))))) + +(ert-deftest test-help-utils-arch-wiki-search-missing-dir-reports-hint () + "Error: the command reports the install hint and opens nothing." + (let ((cj/arch-wiki-html-dir (expand-file-name "definitely-absent-arch-wiki" + temporary-file-directory)) + (said nil) + (opened nil)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq said (apply #'format fmt args)) nil)) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + ;; Must not signal: this is the case that used to raise file-missing. + (cj/local-arch-wiki-search)) + (should-not opened) + (should (string-match-p "arch-wiki-docs" said)))) + +;;; Normal Cases — the command + +(ert-deftest test-help-utils-arch-wiki-search-opens-chosen-topic () + "Normal: the chosen topic is opened as a file URL in EWW." + (test-arch-wiki--with-topics dir '("Systemd") + (let ((cj/arch-wiki-html-dir dir) + (opened nil)) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "Systemd")) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + (cj/local-arch-wiki-search)) + (should (string-prefix-p "file://" opened)) + (should (string-suffix-p "Systemd.html" opened)) + ;; The opened path is the one in the temp dir, not a system copy. + (should (string-match-p (regexp-quote dir) opened))))) + +(ert-deftest test-help-utils-arch-wiki-search-unknown-topic-opens-nothing () + "Boundary: a name matching no topic reports rather than opening." + (test-arch-wiki--with-topics dir '("Systemd") + (let ((cj/arch-wiki-html-dir dir) + (opened nil)) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "NotATopic")) + ((symbol-function 'message) (lambda (&rest _) nil)) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + (cj/local-arch-wiki-search)) + (should-not opened)))) + +(provide 'test-help-utils--arch-wiki-search) +;;; test-help-utils--arch-wiki-search.el ends here diff --git a/tests/test-host-environment--detect-system-timezone.el b/tests/test-host-environment--detect-system-timezone.el index 209283d1..0d76c206 100644 --- a/tests/test-host-environment--detect-system-timezone.el +++ b/tests/test-host-environment--detect-system-timezone.el @@ -17,12 +17,23 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'host-environment) -(ert-deftest test-host-environment-detect-tz-match-localtime-wins () - "Normal: when match-localtime-to-zoneinfo returns a value, that wins." +(ert-deftest test-host-environment-detect-tz-env-wins-without-content-scan () + "Normal: an explicit TZ wins and the exhaustive zoneinfo scan never runs. +The scan reads hundreds of files; it used to run first on every call even +when a cheap O(1) method would answer." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) - (lambda () "America/Los_Angeles")) + (lambda () (error "content scan should not have run"))) ((symbol-function 'getenv) - (lambda (_ &rest _) (error "TZ should not have been consulted")))) + (lambda (name &rest _) (when (string= name "TZ") "America/Chicago")))) + (should (equal (cj/detect-system-timezone) "America/Chicago")))) + +(ert-deftest test-host-environment-detect-tz-content-scan-is-last-resort () + "Boundary: with every cheap method empty, the content scan still answers." + (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) + (lambda () "America/Los_Angeles")) + ((symbol-function 'getenv) (lambda (&rest _) nil)) + ((symbol-function 'file-exists-p) (lambda (&rest _) nil)) + ((symbol-function 'file-symlink-p) (lambda (&rest _) nil))) (should (equal (cj/detect-system-timezone) "America/Los_Angeles")))) (ert-deftest test-host-environment-detect-tz-env-var-wins-when-match-nil () diff --git a/tests/test-httpd-config--defer.el b/tests/test-httpd-config--defer.el new file mode 100644 index 00000000..1a1fbbed --- /dev/null +++ b/tests/test-httpd-config--defer.el @@ -0,0 +1,34 @@ +;;; test-httpd-config--defer.el --- Tests for httpd-config lazy loading -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins httpd-config's load-time behavior: merely loading the module must +;; not create the www directory (that belongs to the moment simple-httpd +;; actually loads) and must not pull in simple-httpd itself — +;; impatient-mode requires it on demand. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) + +;;; Boundary Cases + +(ert-deftest test-httpd-config-load-creates-no-www-dir () + "Boundary: loading httpd-config does not create www/ in user-emacs-directory." + (let* ((sandbox (make-temp-file "httpd-config-test-" t)) + (user-emacs-directory (file-name-as-directory sandbox))) + (unwind-protect + (progn + (require 'httpd-config) + (should-not (file-directory-p + (expand-file-name "www" user-emacs-directory)))) + (delete-directory sandbox t)))) + +(ert-deftest test-httpd-config-load-does-not-load-simple-httpd () + "Boundary: loading httpd-config leaves simple-httpd unloaded." + (require 'httpd-config) + (should-not (featurep 'simple-httpd))) + +(provide 'test-httpd-config--defer) +;;; test-httpd-config--defer.el ends here diff --git a/tests/test-hugo-config--keymap.el b/tests/test-hugo-config--keymap.el new file mode 100644 index 00000000..0f8df257 --- /dev/null +++ b/tests/test-hugo-config--keymap.el @@ -0,0 +1,71 @@ +;;; test-hugo-config--keymap.el --- Tests for the Hugo prefix keymap -*- lexical-binding: t; -*- + +;;; Commentary: +;; Pins the eight Hugo commands reachable under the "C-; h" prefix. +;; +;; The module used to install these with eight raw `global-set-key' calls plus +;; a hand-written which-key block, writing into the global map directly instead +;; of going through `cj/register-prefix-map' the way its siblings +;; (erc-config, custom-ordering, org-reveal-config) do. These tests were added +;; alongside that conversion so the refactor is checkable: every key must still +;; reach the same command afterward. +;; +;; Test organization: +;; - Normal Cases: each of the eight keys resolves to its command +;; - Boundary Cases: case-distinct pairs stay distinct; the map is a prefix map +;; - Error Cases: an unbound key in the map resolves to nothing +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(provide 'ox-hugo) +(require 'hugo-config) +(require 'keybindings) + +(defconst test-hugo--expected-bindings + '(("n" . cj/hugo-new-post) + ("e" . cj/hugo-export-post) + ("o" . cj/hugo-open-blog-dir) + ("O" . cj/hugo-open-blog-dir-external) + ("d" . cj/hugo-open-draft) + ("D" . cj/hugo-toggle-draft) + ("p" . cj/hugo-preview) + ("P" . cj/hugo-publish)) + "Every key the Hugo prefix map must carry, and the command it runs.") + +;;; Normal Cases + +(ert-deftest test-hugo-config-keymap-binds-every-command () + "Normal: each Hugo key resolves to its command inside the prefix map." + (dolist (pair test-hugo--expected-bindings) + (should (eq (cdr pair) (keymap-lookup cj/hugo-keymap (car pair)))))) + +(ert-deftest test-hugo-config-keymap-registered-under-custom-prefix () + "Normal: the map is reachable at \"h\" within `cj/custom-keymap'." + (should (eq cj/hugo-keymap (keymap-lookup cj/custom-keymap "h")))) + +;;; Boundary Cases + +(ert-deftest test-hugo-config-keymap-case-pairs-stay-distinct () + "Boundary: the shifted variants run different commands than their lowercase +counterparts, which a case-folding binding would silently collapse." + (should-not (eq (keymap-lookup cj/hugo-keymap "o") + (keymap-lookup cj/hugo-keymap "O"))) + (should-not (eq (keymap-lookup cj/hugo-keymap "d") + (keymap-lookup cj/hugo-keymap "D"))) + (should-not (eq (keymap-lookup cj/hugo-keymap "p") + (keymap-lookup cj/hugo-keymap "P")))) + +(ert-deftest test-hugo-config-keymap-is-a-keymap () + "Boundary: the value registered as a prefix is an actual keymap." + (should (keymapp cj/hugo-keymap))) + +;;; Error Cases + +(ert-deftest test-hugo-config-keymap-unbound-key-is-nil () + "Error: a key the map does not define resolves to nothing." + (should-not (keymap-lookup cj/hugo-keymap "z"))) + +(provide 'test-hugo-config--keymap) +;;; test-hugo-config--keymap.el ends here diff --git a/tests/test-integration-calendar-sync-timezone.el b/tests/test-integration-calendar-sync-timezone.el index 304d3233..a3f65146 100644 --- a/tests/test-integration-calendar-sync-timezone.el +++ b/tests/test-integration-calendar-sync-timezone.el @@ -187,12 +187,21 @@ Components integrated: Validates: - Org timestamp format is correct (<YYYY-MM-DD Day HH:MM-HH:MM>) -- Hour in timestamp is the converted local hour" - (let* ((source-time (list 2026 2 2 19 0)) +- Hour in timestamp is the converted local hour + +The date is generated relative to now because `calendar-sync--parse-ics' +drops events outside `calendar-sync--get-date-range' (today minus +`calendar-sync-past-months', plus `calendar-sync-future-months'). This test +used a hardcoded 2026-02-02, which sat inside that window when it was written +and fell out of it once three months had passed -- the event was filtered +before rendering and the assertion failed against an empty org buffer. The +sibling tests survived hardcoded dates only because they call +`calendar-sync--parse-event' directly, which applies no range filter." + (let* ((source-time (test-calendar-sync-time-days-from-now 7 19 0)) (ics (test-integration-tz--make-ics-with-tzid-event "Test Event" source-time "Europe/Lisbon")) - (expected-local (test-calendar-sync-convert-tz-via-date - 2026 2 2 19 0 "Europe/Lisbon")) + (expected-local (apply #'test-calendar-sync-convert-tz-via-date + (append source-time (list "Europe/Lisbon")))) (expected-hour (nth 3 expected-local)) (org-output (calendar-sync--parse-ics ics))) (should org-output) diff --git a/tests/test-integration-org-agenda-frame-load-order.el b/tests/test-integration-org-agenda-frame-load-order.el new file mode 100644 index 00000000..a8eeaa47 --- /dev/null +++ b/tests/test-integration-org-agenda-frame-load-order.el @@ -0,0 +1,89 @@ +;;; test-integration-org-agenda-frame-load-order.el --- Frame allowlist survives load order -*- lexical-binding: t; -*- + +;;; Commentary: +;; Regression test for a load-order bug in the Full Agenda frame's read-only +;; shadow. +;; +;; Components integrated: +;; - org-agenda-frame (real, loaded in a subprocess) +;; - org-agenda (real, loaded BEFORE the frame module to reproduce the bug) +;; +;; The bug: cj/--agenda-frame-shadow-mutations walks org-agenda-mode-map and +;; keeps a key only when the frame map already binds it to a `commandp' value. +;; The view/redo handlers (day-view, week-view, safe-redo) were defined LOWER in +;; the file than the `with-eval-after-load' that ran the walk. When org-agenda +;; was already loaded at frame-load time -- the normal startup order and every +;; reload -- the walk fired before those defuns existed, read them as not-yet +;; commands, and denied d/w/g/r, the very keys the allowlist grants. Moving the +;; walk to the end of the file (after the defuns) fixed it. +;; +;; This test can't reproduce the ordering in-process (the module is already +;; loaded), so it drives a fresh Emacs that requires org-agenda first, then the +;; frame module, and inspects the resulting keymap. +;; +;; Validates: +;; - d/w/g/r keep their allowlist commands in the org-first load order +;; - the controlled status/priority mutations survive the shadow walk +;; - a non-allowlisted mutation key (t) is still denied +;; +;;; Code: + +(require 'ert) + +(defconst test-oaf--repo-root + (file-name-directory (directory-file-name + (file-name-directory (or load-file-name buffer-file-name)))) + "Repo root, one level up from tests/.") + +(defun test-oaf--lookup-in-subprocess (keys) + "Load org-agenda then org-agenda-frame in a fresh Emacs, return KEYS' bindings. +Returns an alist of (KEY . BINDING-SYMBOL-NAME-OR-nil)." + (let* ((root test-oaf--repo-root) + (form + (prin1-to-string + `(progn + (setq load-prefer-newer t) + (package-initialize) + (require 'org-agenda) ; the bad order: org first + (require 'org-agenda-frame) + (princ (prin1-to-string + (mapcar + (lambda (k) + (cons k (let ((b (lookup-key cj/agenda-frame-mode-map (kbd k)))) + (and (symbolp b) (symbol-name b))))) + ',keys)))))) + (out (with-output-to-string + (with-current-buffer standard-output + (call-process + (expand-file-name invocation-name invocation-directory) + nil t nil + "--batch" "--no-site-file" "--no-site-lisp" + "-L" root + "-L" (expand-file-name "modules" root) + "-L" (expand-file-name "themes" root) + "--eval" form))))) + (car (read-from-string out)))) + +(ert-deftest test-integration-org-agenda-frame-allowlist-survives-org-first-load () + "Integration: with org-agenda loaded before the frame module, the allowlisted +view/redo and controlled task-mutation keys survive while t stays denied." + (skip-unless (file-exists-p (expand-file-name "modules/org-agenda-frame.el" + test-oaf--repo-root))) + (let ((got (test-oaf--lookup-in-subprocess + '("d" "w" "g" "r" "C-c t" "C-c C-t" + "M-<up>" "M-<right>" "s-<down>" "s-<left>" "t")))) + (should (equal "cj/--agenda-frame-day-view" (cdr (assoc "d" got)))) + (should (equal "cj/--agenda-frame-week-view" (cdr (assoc "w" got)))) + (should (equal "cj/--agenda-frame-safe-redo" (cdr (assoc "g" got)))) + (should (equal "cj/--agenda-frame-safe-redo" (cdr (assoc "r" got)))) + (should (equal "org-agenda-todo" (cdr (assoc "C-c t" got)))) + (should (equal "org-agenda-todo" (cdr (assoc "C-c C-t" got)))) + (should (equal "org-agenda-priority-up" (cdr (assoc "M-<up>" got)))) + (should (equal "org-agenda-todo-nextset" (cdr (assoc "M-<right>" got)))) + (should (equal "org-agenda-priority-down" (cdr (assoc "s-<down>" got)))) + (should (equal "org-agenda-todo-previousset" (cdr (assoc "s-<left>" got)))) + ;; t is a real org mutation key; it must be denied, not allowlisted. + (should (equal "cj/--agenda-frame-denied-readonly" (cdr (assoc "t" got)))))) + +(provide 'test-integration-org-agenda-frame-load-order) +;;; test-integration-org-agenda-frame-load-order.el ends here diff --git a/tests/test-integration-recording-device-workflow.el b/tests/test-integration-recording-device-workflow.el index 3ef631f3..27ffac56 100644 --- a/tests/test-integration-recording-device-workflow.el +++ b/tests/test-integration-recording-device-workflow.el @@ -1,26 +1,24 @@ ;;; test-integration-recording-device-workflow.el --- Integration tests for recording device workflow -*- lexical-binding: t; -*- ;;; Commentary: -;; Integration tests covering the complete device detection and grouping workflow. -;; -;; This tests the full pipeline from raw pactl output through parsing, grouping, -;; and friendly name assignment. The workflow enables users to select audio devices -;; for recording calls/meetings. +;; Integration test covering the device detection path that recording actually +;; uses: raw pactl output through parsing and into friendly state names. ;; ;; Components integrated: ;; - cj/recording--parse-pactl-output (parse raw pactl output into structured data) -;; - cj/recording-parse-sources (shell command wrapper) -;; - cj/recording-group-devices-by-hardware (group inputs/monitors by device) +;; - cj/recording-parse-sources (shell command wrapper, MOCKED at +;; shell-command-to-string so no pactl runs) ;; - cj/recording-friendly-state (convert technical state names) -;; - Bluetooth MAC address normalization (colons → underscores) -;; - Device name pattern matching (USB, PCI, Bluetooth) -;; - Friendly name assignment (user-facing device names) ;; ;; Critical integration points: -;; - Parse output must produce data that group-devices can process -;; - Bluetooth MAC normalization must work across parse→group boundary -;; - Incomplete devices (only mic OR only monitor) must be filtered -;; - Friendly names must correctly identify device types +;; - Parse output must carry device state through to the friendly-name conversion +;; +;; This file once covered a parse-to-group pipeline as well. That half tested +;; cj/recording-group-devices-by-hardware, a second device-grouping +;; implementation nothing ever called -- cj/recording-select-device is the live +;; selection path and reaches parse-sources directly. The function and its +;; tests were removed rather than left as coverage that proved an unused code +;; path worked. ;;; Code: @@ -46,58 +44,6 @@ ;;; Normal Cases - Complete Workflow -(ert-deftest test-integration-recording-device-workflow-parse-to-group-all-devices () - "Test complete workflow from pactl output to grouped devices. - -When pactl output contains all three device types (built-in, USB, Bluetooth), -the workflow should parse, group, and assign friendly names to all devices. - -Components integrated: -- cj/recording--parse-pactl-output (parsing) -- cj/recording-group-devices-by-hardware (grouping + MAC normalization) -- Device pattern matching (USB/PCI/Bluetooth detection) -- Friendly name assignment - -Validates: -- All three device types are detected -- Bluetooth MAC addresses normalized (colons → underscores) -- Each device has both mic and monitor -- Friendly names correctly assigned -- Complete data flow: raw output → parsed list → grouped pairs" - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - ;; Test parse step - (let ((parsed (cj/recording-parse-sources))) - (should (= 6 (length parsed))) - - ;; Test group step (receives parsed data) - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 3 (length grouped))) - - ;; Validate built-in device - (let ((built-in (assoc "Built-in Audio" grouped))) - (should built-in) - (should (string-prefix-p "alsa_input.pci" (cadr built-in))) - (should (string-prefix-p "alsa_output.pci" (cddr built-in)))) - - ;; Validate USB device - (let ((usb (assoc "Jabra SPEAK 510 USB" grouped))) - (should usb) - (should (string-match-p "Jabra" (cadr usb))) - (should (string-match-p "Jabra" (cddr usb)))) - - ;; Validate Bluetooth device (CRITICAL: MAC normalization) - (let ((bluetooth (assoc "Bluetooth Headset" grouped))) - (should bluetooth) - ;; Input has colons - (should (string-match-p "00:1B:66:C0:91:6D" (cadr bluetooth))) - ;; Output has underscores - (should (string-match-p "00_1B_66_C0_91_6D" (cddr bluetooth))) - ;; But they're grouped together! - (should (equal "bluez_input.00:1B:66:C0:91:6D" (cadr bluetooth))) - (should (equal "bluez_output.00_1B_66_C0_91_6D.1.monitor" (cddr bluetooth))))))))) - (ert-deftest test-integration-recording-device-workflow-friendly-states-in-list () "Test that friendly state names appear in device list output. @@ -128,105 +74,5 @@ Validates: ;;; Boundary Cases - Incomplete Devices -(ert-deftest test-integration-recording-device-workflow-incomplete-devices-filtered () - "Test that devices with only mic OR only monitor are filtered out. - -For call recording, we need BOTH mic and monitor from the same device. -Incomplete devices should not appear in the grouped output. - -Components integrated: -- cj/recording-parse-sources (parsing all devices) -- cj/recording-group-devices-by-hardware (filtering incomplete pairs) - -Validates: -- Device with only mic is filtered -- Device with only monitor is filtered -- Only complete devices (both mic and monitor) are returned -- Filtering happens at group stage, not parse stage" - (let ((output (concat - ;; Complete device - "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - "49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - ;; Incomplete: USB mic with no monitor - "100\talsa_input.usb-device.mono-fallback\tPipeWire\ts16le 1ch 16000Hz\tSUSPENDED\n" - ;; Incomplete: Bluetooth monitor with no mic - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - ;; Parse sees all 4 devices - (let ((parsed (cj/recording-parse-sources))) - (should (= 4 (length parsed))) - - ;; Group returns only 1 complete device - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 1 (length grouped))) - (should (equal "Built-in Audio" (caar grouped)))))))) - -;;; Edge Cases - Bluetooth MAC Normalization - -(ert-deftest test-integration-recording-device-workflow-bluetooth-mac-variations () - "Test Bluetooth MAC normalization with different formats. - -Bluetooth devices use colons in input names but underscores in output names. -The grouping must normalize these to match devices correctly. - -Components integrated: -- cj/recording-parse-sources (preserves original MAC format) -- cj/recording-group-devices-by-hardware (normalizes MAC for matching) -- Base name extraction (regex patterns) -- MAC address transformation (underscores → colons) - -Validates: -- Input with colons (bluez_input.AA:BB:CC:DD:EE:FF) parsed correctly -- Output with underscores (bluez_output.AA_BB_CC_DD_EE_FF) parsed correctly -- Normalization happens during grouping -- Devices paired despite format difference -- Original device names preserved (not mutated)" - (let ((output (concat - "79\tbluez_input.11:22:33:44:55:66\tPipeWire\tfloat32le 1ch 48000Hz\tSUSPENDED\n" - "81\tbluez_output.11_22_33_44_55_66.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((parsed (cj/recording-parse-sources))) - ;; Original formats preserved in parse - (should (string-match-p "11:22:33" (caar parsed))) - (should (string-match-p "11_22_33" (caadr parsed))) - - ;; But grouping matches them - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 1 (length grouped))) - (should (equal "Bluetooth Headset" (caar grouped))) - ;; Original names preserved - (should (equal "bluez_input.11:22:33:44:55:66" (cadar grouped))) - (should (equal "bluez_output.11_22_33_44_55_66.1.monitor" (cddar grouped)))))))) - -;;; Error Cases - Malformed Data - -(ert-deftest test-integration-recording-device-workflow-malformed-output-handled () - "Test that malformed pactl output is handled gracefully. - -When pactl output is malformed or unparseable, the workflow should not crash. -It should return empty results at appropriate stages. - -Components integrated: -- cj/recording--parse-pactl-output (malformed line handling) -- cj/recording-group-devices-by-hardware (empty input handling) - -Validates: -- Malformed lines are silently skipped during parse -- Empty parse results don't crash grouping -- Workflow degrades gracefully -- No exceptions thrown" - (let ((output (test-load-fixture "pactl-output-malformed.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((parsed (cj/recording-parse-sources))) - ;; Malformed output produces empty parse - (should (null parsed)) - - ;; Empty parse produces empty grouping (no crash) - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (null grouped))))))) - (provide 'test-integration-recording-device-workflow) ;;; test-integration-recording-device-workflow.el ends here diff --git a/tests/test-integration-recording-toggle-workflow.el b/tests/test-integration-recording-toggle-workflow.el index e73ef87e..6258fc58 100644 --- a/tests/test-integration-recording-toggle-workflow.el +++ b/tests/test-integration-recording-toggle-workflow.el @@ -43,6 +43,24 @@ ;;; Setup and Teardown +(defun test-integration-toggle--fake-pactl (cmd &rest _) + "Answer pactl queries for CMD from fixture devices, never the real machine. + +`cj/recording-get-devices' runs `cj/recording--validate-system-audio', which +shells out to pactl, decides a fixture device name is not a real source, and +\"auto-fixes\" the configured device to the default sink's monitor. Left +unmocked that clobbers the test's device with whatever hardware the developer +has plugged in, so the assertions compare against a JDS Labs DAC rather than +the fixture. Answering at the shell boundary keeps the real validation logic +under test while the machine stays out of it." + (cond + ((string-match-p "get-default-sink" cmd) "fixture-sink\n") + ((string-match-p "list sources short" cmd) + "0\ttest-monitor\tmodule-x\ts16le 2ch 44100Hz\tIDLE\n1\tcached-monitor\tmodule-x\ts16le 2ch 44100Hz\tIDLE\n") + ((string-match-p "list sinks short" cmd) + "0\tfixture-sink\tmodule-x\ts16le 2ch 44100Hz\tRUNNING\n") + (t ""))) + (defun test-integration-toggle-setup () "Reset all variables before each test." (setq cj/video-recording-ffmpeg-process nil) @@ -102,6 +120,8 @@ Validates: (setq setup-called t) (setq cj/recording-mic-device "test-mic") (setq cj/recording-system-device "test-monitor"))) + ((symbol-function 'shell-command-to-string) + #'test-integration-toggle--fake-pactl) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ((symbol-function 'start-process-shell-command) @@ -168,6 +188,8 @@ Validates: (ffmpeg-cmd nil)) (cl-letf (((symbol-function 'cj/recording-quick-setup) (lambda () (setq setup-called t))) + ((symbol-function 'shell-command-to-string) + #'test-integration-toggle--fake-pactl) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ((symbol-function 'start-process-shell-command) diff --git a/tests/test-integration-recurring-events.el b/tests/test-integration-recurring-events.el index 3cae1a20..8339d167 100644 --- a/tests/test-integration-recurring-events.el +++ b/tests/test-integration-recurring-events.el @@ -34,53 +34,78 @@ ;;; Test Data -(defconst test-integration-recurring-events--weekly-ics - "BEGIN:VCALENDAR -VERSION:2.0 -PRODID:-//Test//Test//EN -BEGIN:VEVENT -DTSTART;TZID=America/Chicago:20251118T103000 -DTEND;TZID=America/Chicago:20251118T110000 -RRULE:FREQ=WEEKLY;BYDAY=SA -SUMMARY:GTFO -UID:test-weekly@example.com -END:VEVENT -END:VCALENDAR" - "Test ICS with weekly recurring event (GTFO use case).") +;; Fixtures that reach `calendar-sync--parse-ics' must carry dates relative to +;; now. That entry point drops any event outside +;; `calendar-sync--get-date-range' (today minus `calendar-sync-past-months', +;; plus `calendar-sync-future-months'), so a hardcoded DTSTART works only until +;; the rolling window moves past it. Three tests here rotted exactly that way: +;; their November-2025 fixtures aged out of the window, the events were filtered +;; before rendering, and the assertions failed against an empty org buffer. The +;; weekly fixtures survived only because an unbounded RRULE keeps generating +;; occurrences into the window no matter how old its DTSTART is. +;; +;; Fixtures given straight to `calendar-sync--parse-event' can stay static -- +;; that path applies no range filter. -(defconst test-integration-recurring-events--daily-with-count-ics - "BEGIN:VCALENDAR +(defun test-integration-recurring-events--ics-stamp (offset-days hour minute) + "Return an ICS UTC datetime OFFSET-DAYS from today at HOUR:MINUTE." + (let ((d (test-calendar-sync-time-days-from-now offset-days hour minute))) + (format "%04d%02d%02dT%02d%02d00Z" (nth 0 d) (nth 1 d) (nth 2 d) hour minute))) + +(defun test-integration-recurring-events--daily-with-count-ics () + "ICS with a COUNT=5 daily series starting inside the sync window." + (format "BEGIN:VCALENDAR VERSION:2.0 PRODID:-//Test//Test//EN BEGIN:VEVENT -DTSTART:20251120T090000Z -DTEND:20251120T100000Z +DTSTART:%s +DTEND:%s RRULE:FREQ=DAILY;COUNT=5 SUMMARY:Daily Standup UID:test-daily@example.com END:VEVENT END:VCALENDAR" - "Test ICS with daily recurring event limited by COUNT.") + (test-integration-recurring-events--ics-stamp 2 9 0) + (test-integration-recurring-events--ics-stamp 2 10 0))) -(defconst test-integration-recurring-events--mixed-ics - "BEGIN:VCALENDAR +(defun test-integration-recurring-events--mixed-ics () + "ICS mixing a one-time event and a recurring one, both inside the window." + (format "BEGIN:VCALENDAR VERSION:2.0 PRODID:-//Test//Test//EN BEGIN:VEVENT -DTSTART:20251125T140000Z -DTEND:20251125T150000Z +DTSTART:%s +DTEND:%s SUMMARY:One-time Meeting UID:test-onetime@example.com END:VEVENT BEGIN:VEVENT -DTSTART;TZID=America/Chicago:20251201T093000 -DTEND;TZID=America/Chicago:20251201T103000 +DTSTART;TZID=America/Chicago:%s +DTEND;TZID=America/Chicago:%s RRULE:FREQ=WEEKLY;BYDAY=MO,WE,FR SUMMARY:Recurring Standup UID:test-recurring@example.com END:VEVENT END:VCALENDAR" - "Test ICS with mix of recurring and non-recurring events.") + (test-integration-recurring-events--ics-stamp 3 14 0) + (test-integration-recurring-events--ics-stamp 3 15 0) + ;; TZID form carries no Z suffix. + (string-remove-suffix "Z" (test-integration-recurring-events--ics-stamp 5 9 30)) + (string-remove-suffix "Z" (test-integration-recurring-events--ics-stamp 5 10 30)))) + +(defconst test-integration-recurring-events--weekly-ics + "BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Test//Test//EN +BEGIN:VEVENT +DTSTART;TZID=America/Chicago:20251118T103000 +DTEND;TZID=America/Chicago:20251118T110000 +RRULE:FREQ=WEEKLY;BYDAY=SA +SUMMARY:GTFO +UID:test-weekly@example.com +END:VEVENT +END:VCALENDAR" + "Test ICS with weekly recurring event (GTFO use case).") ;;; Normal Cases - Complete Workflow @@ -133,7 +158,7 @@ Validates: - Exactly 5 occurrences created" (test-integration-recurring-events-setup) (unwind-protect - (let ((org-output (calendar-sync--parse-ics test-integration-recurring-events--daily-with-count-ics))) + (let ((org-output (calendar-sync--parse-ics (test-integration-recurring-events--daily-with-count-ics)))) (should (stringp org-output)) ;; Should generate exactly 5 Daily Standup entries @@ -160,7 +185,7 @@ Validates: - Events are sorted chronologically" (test-integration-recurring-events-setup) (unwind-protect - (let ((org-output (calendar-sync--parse-ics test-integration-recurring-events--mixed-ics))) + (let ((org-output (calendar-sync--parse-ics (test-integration-recurring-events--mixed-ics)))) (should (stringp org-output)) ;; Should have one-time meeting @@ -197,12 +222,19 @@ Validates: (test-integration-recurring-events-setup) (unwind-protect (let* ((org-output (calendar-sync--parse-ics test-integration-recurring-events--weekly-ics)) - (now (current-time)) - (three-months-ago (time-subtract now (* 90 24 3600))) - (twelve-months-future (time-add now (* 365 24 3600)))) + (range (calendar-sync--get-date-range)) + (window-start (nth 0 range)) + (window-end (nth 1 range))) (should (stringp org-output)) - ;; Parse all dates from output + ;; Every emitted occurrence must fall within the pipeline's own window + ;; (-3/+12 calendar months at day granularity, from + ;; `calendar-sync--get-date-range'). Asserting against that boundary, + ;; rather than a hand-rolled now +/- fixed-day approximation, keeps the + ;; test robust on every date: a valid boundary occurrence stamped at + ;; midnight used to read as out-of-range against a now-90d bound taken + ;; at the current clock time, so the test failed or passed depending on + ;; the day it ran. (with-temp-buffer (insert org-output) (goto-char (point-min)) @@ -212,9 +244,9 @@ Validates: (month (string-to-number (match-string 2))) (day (string-to-number (match-string 3))) (event-time (encode-time 0 0 0 day month year))) - ;; All dates should be within window - (when (or (time-less-p event-time three-months-ago) - (time-less-p twelve-months-future event-time)) + ;; Within [window-start, window-end] inclusive. + (when (or (time-less-p event-time window-start) + (time-less-p window-end event-time)) (setq all-dates-in-range nil)))) (should all-dates-in-range)))) (test-integration-recurring-events-teardown))) @@ -291,18 +323,21 @@ Validates: - Valid events still processed" (test-integration-recurring-events-setup) (unwind-protect - (let* ((incomplete-ics "BEGIN:VCALENDAR + (let* ((incomplete-ics (format "BEGIN:VCALENDAR VERSION:2.0 BEGIN:VEVENT -DTSTART:20251201T100000Z +DTSTART:%s RRULE:FREQ=DAILY;COUNT=2 END:VEVENT BEGIN:VEVENT SUMMARY:Valid Event -DTSTART:20251201T110000Z -DTEND:20251201T120000Z +DTSTART:%s +DTEND:%s END:VEVENT -END:VCALENDAR") +END:VCALENDAR" + (test-integration-recurring-events--ics-stamp 4 10 0) + (test-integration-recurring-events--ics-stamp 4 11 0) + (test-integration-recurring-events--ics-stamp 4 12 0))) (org-output (calendar-sync--parse-ics incomplete-ics))) ;; Should still generate output (for valid event) (should (stringp org-output)) diff --git a/tests/test-jumper.el b/tests/test-jumper.el index fa65d3f4..638f2aa2 100644 --- a/tests/test-jumper.el +++ b/tests/test-jumper.el @@ -348,5 +348,30 @@ (should (string-match-p "test line" formatted)))) (test-jumper-teardown)) +;;; Empty completing-read input (vertico-less UI can return "") + +(ert-deftest test-jumper-jump-empty-choice-signals-user-error () + "Error: empty input at the jump prompt gives a user-error, not a crash. +An unmatched choice makes (cdr (assoc ...)) nil, which used to flow into +the index arithmetic and signal wrong-type-argument." + (let ((jumper--next-index 2)) + (cl-letf (((symbol-function 'jumper--location-candidates) + (lambda () '(("[0] here" . 0) ("[1] there" . 1)))) + ((symbol-function 'get-register) (lambda (_r) nil)) + ((symbol-function 'completing-read) (lambda (&rest _) ""))) + (should-error (jumper-jump-to-location) :type 'user-error)))) + +(ert-deftest test-jumper-remove-empty-choice-cancels () + "Boundary: empty input at the remove prompt cancels instead of crashing." + (let ((jumper--next-index 2) + removed) + (cl-letf (((symbol-function 'jumper--location-candidates) + (lambda () '(("[0] here" . 0) ("[1] there" . 1)))) + ((symbol-function 'completing-read) (lambda (&rest _) "")) + ((symbol-function 'jumper--reorder-registers) + (lambda (_i) (setq removed t)))) + (jumper-remove-location) + (should-not removed)))) + (provide 'test-jumper) ;;; test-jumper.el ends here diff --git a/tests/test-media-utils--argv.el b/tests/test-media-utils--argv.el new file mode 100644 index 00000000..81317b60 --- /dev/null +++ b/tests/test-media-utils--argv.el @@ -0,0 +1,72 @@ +;;; test-media-utils--argv.el --- Tests for media-utils argv builders -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for the pure helpers behind cj/media-play-it's shell-free +;; launch: cj/media--yt-dlp-argv (stream-URL resolution command), +;; cj/media--stream-urls (yt-dlp -g output parsing), and +;; cj/media--play-argv (player launch argv). Argv lists are the +;; hardening: URLs and args never meet a shell. +;; +;; Test organization: +;; - Normal Cases: formats present/absent, args split, multi-line output +;; - Boundary Cases: metacharacter URLs verbatim, empty output, nil args +;; - Error Cases: none (builders are total; error paths live in the caller) +;; +;;; Code: + +(require 'ert) +(require 'media-utils) + +;;; cj/media--yt-dlp-argv + +(ert-deftest test-media-utils--yt-dlp-argv-normal-with-formats () + "Normal: formats join with / behind -f, URL last." + (should (equal (cj/media--yt-dlp-argv "https://example.com/v" '("22" "18" "best")) + '("yt-dlp" "-f" "22/18/best" "-g" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dlp-argv-normal-without-formats () + "Normal: nil formats drops the -f pair." + (should (equal (cj/media--yt-dlp-argv "https://example.com/v" nil) + '("yt-dlp" "-g" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dlp-argv-boundary-metacharacter-url () + "Boundary: a URL with shell metacharacters stays one verbatim element." + (let ((url "https://example.com/v?a=1&b=$(x);c='d'")) + (should (equal (car (last (cj/media--yt-dlp-argv url nil))) url)))) + +;;; cj/media--stream-urls + +(ert-deftest test-media-utils--stream-urls-normal-two-lines () + "Normal: each non-empty output line is one stream URL." + (should (equal (cj/media--stream-urls "https://a/video\nhttps://a/audio\n") + '("https://a/video" "https://a/audio")))) + +(ert-deftest test-media-utils--stream-urls-boundary-blank-and-crlf () + "Boundary: blank lines and CR line endings are stripped." + (should (equal (cj/media--stream-urls "https://a/v\r\n\n \nhttps://a/u\r\n") + '("https://a/v" "https://a/u")))) + +(ert-deftest test-media-utils--stream-urls-boundary-empty-output () + "Boundary: empty output yields nil." + (should-not (cj/media--stream-urls ""))) + +;;; cj/media--play-argv + +(ert-deftest test-media-utils--play-argv-normal-args-split () + "Normal: the player's raw args string splits into argv words." + (should (equal (cj/media--play-argv "vlc" "--no-video --intf dummy" + '("https://a/v")) + '("vlc" "--no-video" "--intf" "dummy" "https://a/v")))) + +(ert-deftest test-media-utils--play-argv-boundary-nil-args () + "Boundary: nil args yields program + URLs only." + (should (equal (cj/media--play-argv "mpv" nil '("https://a/v")) + '("mpv" "https://a/v")))) + +(ert-deftest test-media-utils--play-argv-boundary-multiple-urls () + "Boundary: every resolved stream URL is appended in order." + (should (equal (cj/media--play-argv "mpv" nil '("https://a/v" "https://a/u")) + '("mpv" "https://a/v" "https://a/u")))) + +(provide 'test-media-utils--argv) +;;; test-media-utils--argv.el ends here diff --git a/tests/test-media-utils--yt-dl-message.el b/tests/test-media-utils--yt-dl-message.el new file mode 100644 index 00000000..491b64cf --- /dev/null +++ b/tests/test-media-utils--yt-dl-message.el @@ -0,0 +1,64 @@ +;;; test-media-utils--yt-dl-message.el --- Tests for the yt-dl sentinel message -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for cj/media--yt-dl-message, the pure helper behind +;; cj/yt-dl-it's process sentinel. +;; +;; The behavior under test is a correctness fix, not cosmetics. cj/yt-dl-it +;; launches "tsp yt-dlp ...", and tsp enqueues the job and exits immediately. +;; The sentinel therefore fires on tsp's exit, not on yt-dlp's, so the old +;; "Finished downloading" text claimed a completed download at the moment the +;; download was merely queued -- and a yt-dlp failure minutes later was silent. +;; The helper reports queueing, which is the only thing tsp's exit actually +;; proves. +;; +;; Test organization: +;; - Normal Cases: clean tsp exit reports queued; abnormal exit reports failure +;; - Boundary Cases: unrelated events return nil; URL text passes through verbatim +;; - Error Cases: empty event string returns nil +;; +;;; Code: + +(require 'ert) +(require 'media-utils) + +;;; Normal Cases + +(ert-deftest test-media-utils--yt-dl-message-normal-finished-says-queued () + "Normal: a clean tsp exit reports the job queued, never downloaded." + (let ((msg (cj/media--yt-dl-message "finished\n" "https://example.com/v"))) + (should (string-match-p "[Qq]ueued" msg)) + (should-not (string-match-p "[Ff]inished downloading" msg)))) + +(ert-deftest test-media-utils--yt-dl-message-normal-abnormal-reports-failure () + "Normal: an abnormal tsp exit reports that queueing failed." + (let ((msg (cj/media--yt-dl-message "exited abnormally with code 1\n" + "https://example.com/v"))) + (should msg) + (should-not (string-match-p "[Qq]ueued for" msg)))) + +;;; Boundary Cases + +(ert-deftest test-media-utils--yt-dl-message-boundary-unrelated-event-is-nil () + "Boundary: an event that reports neither outcome produces no message." + (should (null (cj/media--yt-dl-message "run\n" "https://example.com/v"))) + (should (null (cj/media--yt-dl-message "stopped\n" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dl-message-boundary-url-passes-through () + "Boundary: the URL text is carried into the message verbatim." + (let ((url "https://example.com/watch?v=a&b=c%20d")) + (should (string-match-p (regexp-quote url) + (cj/media--yt-dl-message "finished\n" url))))) + +(ert-deftest test-media-utils--yt-dl-message-boundary-empty-url () + "Boundary: an empty URL still yields a message rather than signaling." + (should (stringp (cj/media--yt-dl-message "finished\n" "")))) + +;;; Error Cases + +(ert-deftest test-media-utils--yt-dl-message-error-empty-event-is-nil () + "Error: an empty event string matches no outcome and returns nil." + (should (null (cj/media--yt-dl-message "" "https://example.com/v")))) + +(provide 'test-media-utils--yt-dl-message) +;;; test-media-utils--yt-dl-message.el ends here diff --git a/tests/test-media-utils.el b/tests/test-media-utils.el index 841b6faf..23b36eeb 100644 --- a/tests/test-media-utils.el +++ b/tests/test-media-utils.el @@ -38,34 +38,41 @@ ;; ----------------------------- cj/media-play-it ------------------------------ (ert-deftest test-media-play-it-direct-playback-command () - "Normal: a player that needs no stream URL gets a plain command, no yt-dlp." + "Normal: a player that needs no stream URL launches an argv process, no yt-dlp." (let (captured cj/default-media-player) (setq cj/default-media-player '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 'start-process) + (lambda (&rest args) (setq captured args) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) ((symbol-function 'message) #'ignore) ((symbol-function 'cj/log-silently) #'ignore)) (cj/media-play-it "https://example.com/v")) - (should (string-match-p "mpv" captured)) - (should (string-match-p "example\\.com" captured)) - (should-not (string-match-p "yt-dlp" captured)))) - -(ert-deftest test-media-play-it-stream-url-wraps-yt-dlp () - "Normal: a player needing a stream URL wraps the URL in a yt-dlp -g call." - (let (captured cj/default-media-player) + ;; (NAME BUFFER PROGRAM . ARGS) -- program + args are the argv. + (should (equal (nthcdr 2 captured) '("mpv" "https://example.com/v"))) + (should-not (member "yt-dlp" captured)))) + +(ert-deftest test-media-play-it-stream-url-resolves-via-yt-dlp () + "Normal: a stream-URL player resolves through a yt-dlp -g capture, then +launches the player with the resolved URL as argv -- no shell either step." + (let (yt-argv captured cj/default-media-player) (setq cj/default-media-player '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)) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) + ((symbol-function 'call-process) + (lambda (program _infile _dest _display &rest args) + (setq yt-argv (cons program args)) + (insert "https://stream.example.com/resolved\n") + 0)) + ((symbol-function 'start-process) + (lambda (&rest args) (setq captured args) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) ((symbol-function 'message) #'ignore) ((symbol-function 'cj/log-silently) #'ignore)) (cj/media-play-it "https://example.com/v")) - (should (string-match-p "yt-dlp" captured)) - (should (string-match-p "-g" captured)) - (should (string-match-p "-f 22/18/best" captured)))) + (should (equal yt-argv + '("yt-dlp" "-f" "22/18/best" "-g" "https://example.com/v"))) + (should (equal (nthcdr 2 captured) + '("vlc" "https://stream.example.com/resolved"))))) (ert-deftest test-media-play-it-missing-player-errors () "Error: an unavailable player command signals an error before launching." @@ -74,6 +81,73 @@ (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/media-play-it "https://example.com/v"))))) +(ert-deftest test-media-play-it-missing-yt-dlp-errors () + "Error: a stream-URL player with no yt-dlp on PATH aborts before resolving." + (let (cj/default-media-player) + (setq cj/default-media-player 'vlc) + (cl-letf (((symbol-function 'executable-find) + (lambda (cmd &rest _) (and (equal cmd "vlc") "/usr/bin/vlc")))) + (should-error (cj/media-play-it "https://example.com/v"))))) + +(ert-deftest test-media-play-it-yt-dlp-failure-errors () + "Error: a non-zero yt-dlp exit surfaces as an error, player never launches." + (let (launched cj/default-media-player) + (setq cj/default-media-player 'vlc) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) + ((symbol-function 'call-process) + (lambda (&rest _) (insert "ERROR: no video\n") 1)) + ((symbol-function 'start-process) + (lambda (&rest _) (setq launched t) 'proc)) + ((symbol-function 'message) #'ignore)) + (should-error (cj/media-play-it "https://example.com/v"))) + (should-not launched))) + +(ert-deftest test-media-play-it-yt-dlp-empty-output-errors () + "Error: a zero-exit yt-dlp with no output still errors, player never launches." + (let (launched cj/default-media-player) + (setq cj/default-media-player 'vlc) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) + ((symbol-function 'call-process) (lambda (&rest _) 0)) + ((symbol-function 'start-process) + (lambda (&rest _) (setq launched t) 'proc)) + ((symbol-function 'message) #'ignore)) + (should-error (cj/media-play-it "https://example.com/v"))) + (should-not launched))) + +;; -------------------------- cj/media--play-sentinel -------------------------- + +(ert-deftest test-media-utils--play-sentinel-normal-finished-kills-buffer () + "Normal: a finished event reports success and reaps the process buffer." + (let ((buf (generate-new-buffer " *sentinel-test*")) + (said nil)) + (cl-letf (((symbol-function 'process-buffer) (lambda (_p) buf)) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq said (apply #'format fmt args))))) + (funcall (cj/media--play-sentinel "https://a/v") 'proc "finished\n")) + (should (string-match-p "Finished" said)) + (should-not (buffer-live-p buf)))) + +(ert-deftest test-media-utils--play-sentinel-normal-abnormal-exit-kills-buffer () + "Normal: an abnormal exit reports failure and reaps the process buffer." + (let ((buf (generate-new-buffer " *sentinel-test*")) + (said nil)) + (cl-letf (((symbol-function 'process-buffer) (lambda (_p) buf)) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq said (apply #'format fmt args))))) + (funcall (cj/media--play-sentinel "https://a/v") 'proc "exited abnormally with code 2\n")) + (should (string-match-p "failed" said)) + (should-not (buffer-live-p buf)))) + +(ert-deftest test-media-utils--play-sentinel-boundary-other-event-keeps-buffer () + "Boundary: a non-terminal event (e.g. stop) leaves the buffer alone." + (let ((buf (generate-new-buffer " *sentinel-test*"))) + (unwind-protect + (cl-letf (((symbol-function 'process-buffer) (lambda (_p) buf)) + ((symbol-function 'message) #'ignore)) + (funcall (cj/media--play-sentinel "https://a/v") 'proc "stopped\n") + (should (buffer-live-p buf))) + (when (buffer-live-p buf) (kill-buffer buf))))) + ;; ------------------------------- cj/yt-dl-it --------------------------------- (ert-deftest test-media-yt-dl-it-errors-without-yt-dlp () diff --git a/tests/test-music-config--add-dired-selection.el b/tests/test-music-config--add-dired-selection.el new file mode 100644 index 00000000..9380409c --- /dev/null +++ b/tests/test-music-config--add-dired-selection.el @@ -0,0 +1,64 @@ +;;; test-music-config--add-dired-selection.el --- Tests for dired add command -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for cj/music-add-dired-selection. +;; +;; Test organization: +;; - Normal Cases: marked files (no region) are all queued +;; - Boundary Cases: no marks falls back to the file at point +;; - Error Cases: outside dired signals a user-error +;; +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; Stub missing dependencies before loading music-config +(defvar-keymap cj/custom-keymap + :doc "Stub keymap for testing") + +;; Add EMMS elpa directory to load path for batch testing +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir + (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(defun test-add-dired--run (marked) + "Run the command with MARKED as dired's marked-file answer; return added files." + (let (added) + (cl-letf (((symbol-function 'derived-mode-p) (lambda (&rest _) t)) + ((symbol-function 'cj/music--ensure-playlist-buffer) (lambda () nil)) + ((symbol-function 'dired-get-marked-files) + (lambda (&rest _) marked)) + ((symbol-function 'file-directory-p) (lambda (_f) nil)) + ((symbol-function 'cj/music--valid-file-p) (lambda (_f) t)) + ((symbol-function 'emms-add-file) (lambda (f) (push f added))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (cj/music-add-dired-selection) + (nreverse added)))) + +(ert-deftest test-music-add-dired-selection-queues-all-marked-files () + "Normal: files marked with m (no region) are all queued, not just point. +The old gate ran dired-get-marked-files only under use-region-p, so marks +without a region fell to the single-file branch and silently dropped all +but the point file." + (should (equal (test-add-dired--run '("/tmp/a.mp3" "/tmp/b.mp3" "/tmp/c.mp3")) + '("/tmp/a.mp3" "/tmp/b.mp3" "/tmp/c.mp3")))) + +(ert-deftest test-music-add-dired-selection-point-file-when-no-marks () + "Boundary: with no marks, dired-get-marked-files returns the point file." + (should (equal (test-add-dired--run '("/tmp/only.mp3")) + '("/tmp/only.mp3")))) + +(ert-deftest test-music-add-dired-selection-errors-outside-dired () + "Error: outside a dired buffer the command signals a user-error." + (cl-letf (((symbol-function 'derived-mode-p) (lambda (&rest _) nil))) + (should-error (cj/music-add-dired-selection) :type 'user-error))) + +(provide 'test-music-config--add-dired-selection) +;;; test-music-config--add-dired-selection.el ends here diff --git a/tests/test-music-config--after-playlist-clear.el b/tests/test-music-config--after-playlist-clear.el index c23e2b5b..42dcf0e3 100644 --- a/tests/test-music-config--after-playlist-clear.el +++ b/tests/test-music-config--after-playlist-clear.el @@ -112,5 +112,30 @@ (progn (cj/music--after-playlist-clear) nil) (error err))))) +(ert-deftest test-music-header-toggle-advice-is-named-and-installed () + "Normal: the header-refresh toggle advice is a named, removable function. +An anonymous lambda can't be advice-removed and stacks a copy on every +:config reload, firing the header refresh N times per toggle." + (should (fboundp 'cj/music--refresh-header-after-toggle)) + (dolist (fn '(emms-toggle-repeat-playlist + emms-toggle-repeat-track + emms-toggle-random-playlist + cj/music-toggle-consume)) + (should (advice-member-p #'cj/music--refresh-header-after-toggle fn)))) + +(ert-deftest test-music-header-toggle-advice-does-not-stack () + "Boundary: re-running the install (a :config reload) keeps one advice copy." + (dolist (fn '(emms-toggle-repeat-playlist emms-toggle-repeat-track)) + (advice-remove fn #'cj/music--refresh-header-after-toggle) + (advice-add fn :after #'cj/music--refresh-header-after-toggle) + (advice-remove fn #'cj/music--refresh-header-after-toggle) + (advice-add fn :after #'cj/music--refresh-header-after-toggle) + (let ((count 0)) + (advice-mapc (lambda (f _props) + (when (eq f 'cj/music--refresh-header-after-toggle) + (setq count (1+ count)))) + fn) + (should (= count 1))))) + (provide 'test-music-config--after-playlist-clear) ;;; test-music-config--after-playlist-clear.el ends here diff --git a/tests/test-music-config--completion-table.el b/tests/test-music-config--completion-table.el index 5e33e655..6b3da442 100644 --- a/tests/test-music-config--completion-table.el +++ b/tests/test-music-config--completion-table.el @@ -19,6 +19,10 @@ (defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") +;; Declare special here too (the module's bare defvar is file-local) so the +;; registration test's `let' binds dynamically. +(defvar marginalia-annotator-registry) + ;; Load production code (require 'music-config) @@ -131,5 +135,15 @@ ;; Should not crash, returns empty (should (null result)))) +;;; Marginalia registration + +(ert-deftest test-music-config--completion-table-registers-with-marginalia () + "Normal: building the table registers cj-music-file so marginalia +right-aligns the size/date annotations." + (let ((marginalia-annotator-registry '())) + (cj/music--completion-table '("a.mp3")) + (should (equal (assq 'cj-music-file marginalia-annotator-registry) + '(cj-music-file builtin none))))) + (provide 'test-music-config--completion-table) ;;; test-music-config--completion-table.el ends here diff --git a/tests/test-music-config--delete-playlist-file.el b/tests/test-music-config--delete-playlist-file.el new file mode 100644 index 00000000..ace51a4d --- /dev/null +++ b/tests/test-music-config--delete-playlist-file.el @@ -0,0 +1,135 @@ +;;; test-music-config--delete-playlist-file.el --- Tests for playlist file deletion -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for cj/music--delete-playlist-file function. +;; Tests the internal helper that removes a playlist's .m3u file, +;; clears the playlist buffer's file association when it pointed at +;; the deleted file, and refreshes the radio metadata cache. +;; +;; Test organization: +;; - Normal Cases: Existing file is deleted +;; - Boundary Cases: Association cleared only when it matches; cache refresh +;; - Error Cases: Nil path, nonexistent path +;; +;;; Code: + +(require 'ert) +(require 'testutil-general) + +;; Stub missing dependencies before loading music-config +(defvar-keymap cj/custom-keymap + :doc "Stub keymap for testing") + +;; Add EMMS elpa directory to load path for batch testing +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir + (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'emms-playlist-mode) +(require 'music-config) + +;;; Test helpers + +(defun test-delete-playlist--setup () + "Create test base dir and ensure playlist buffer exists." + (cj/create-test-base-dir) + (let ((buf (get-buffer-create cj/music-playlist-buffer-name))) + (with-current-buffer buf + (emms-playlist-mode) + (setq emms-playlist-buffer-p t)) + (setq emms-playlist-buffer buf) + buf)) + +(defun test-delete-playlist--teardown () + "Clean up test playlist buffer and temp files." + (when-let ((buf (get-buffer cj/music-playlist-buffer-name))) + (with-current-buffer buf + (setq cj/music-playlist-file nil)) + (kill-buffer buf)) + (cj/delete-test-base-dir)) + +;;; Normal Cases + +(ert-deftest test-music-config--delete-playlist-file-normal-removes-file () + "Normal: an existing playlist file is deleted from disk." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n/tmp/song.mp3\n" "playlist.m3u"))) + (cj/music--delete-playlist-file file) + (should-not (file-exists-p file))) + (test-delete-playlist--teardown))) + +;;; Boundary Cases + +(ert-deftest test-music-config--delete-playlist-file-boundary-clears-matching-association () + "Boundary: deleting the associated playlist file clears the association." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n" "playlist.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file file)) + (cj/music--delete-playlist-file file) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should-not cj/music-playlist-file))) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-boundary-keeps-other-association () + "Boundary: deleting a different file leaves the association untouched." + (test-delete-playlist--setup) + (unwind-protect + (let ((doomed (cj/create-temp-test-file-with-content + "#EXTM3U\n" "doomed.m3u")) + (kept (cj/create-temp-test-file-with-content + "#EXTM3U\n" "kept.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file kept)) + (cj/music--delete-playlist-file doomed) + (should (file-exists-p kept)) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should (equal cj/music-playlist-file kept)))) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-boundary-refreshes-radio-cache () + "Boundary: deletion clears the cached radio metadata." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n" "playlist.m3u"))) + (setq cj/music--radio-metadata-cache '(("stale" . "entry"))) + (cj/music--delete-playlist-file file) + (should-not cj/music--radio-metadata-cache)) + (test-delete-playlist--teardown))) + +;;; Error Cases + +(ert-deftest test-music-config--delete-playlist-file-error-nil-path () + "Error: nil path signals user-error." + (test-delete-playlist--setup) + (unwind-protect + (should-error (cj/music--delete-playlist-file nil) :type 'user-error) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-error-nonexistent-path () + "Error: a path that does not exist signals user-error and touches nothing." + (test-delete-playlist--setup) + (unwind-protect + (let ((kept (cj/create-temp-test-file-with-content + "#EXTM3U\n" "kept.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file kept)) + (should-error + (cj/music--delete-playlist-file + (expand-file-name "no-such.m3u" cj/test-base-dir)) + :type 'user-error) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should (equal cj/music-playlist-file kept)))) + (test-delete-playlist--teardown))) + +(provide 'test-music-config--delete-playlist-file) +;;; test-music-config--delete-playlist-file.el ends here diff --git a/tests/test-music-config--header-text.el b/tests/test-music-config--header-text.el index 8de97350..c860c6d4 100644 --- a/tests/test-music-config--header-text.el +++ b/tests/test-music-config--header-text.el @@ -139,6 +139,23 @@ (should (string-match-p "consume" plain)))) (test-header--teardown))) +(ert-deftest test-music-config--header-text-boundary-key-hints-single-save-stop () + "Header key hints: single is on 1, save is on s, and stop (S) is gone. +SPC/pause covers stop, so the S:stop hint and the [s] single / v:save hints +are retired." + (unwind-protect + (progn + (test-header--setup-playlist-buffer '("/music/a.mp3")) + (let* ((header (with-current-buffer cj/music-playlist-buffer-name + (cj/music--header-text))) + (plain (test-header--strip-properties header))) + (should (string-match-p "\\[1\\] single" plain)) + (should (string-match-p "s:save" plain)) + (should-not (string-match-p "\\[s\\] single" plain)) + (should-not (string-match-p "v:save" plain)) + (should-not (string-match-p "S:stop" plain)))) + (test-header--teardown))) + ;;; Error Cases (ert-deftest test-music-config--header-text-error-empty-playlist-shows-zero-count () diff --git a/tests/test-music-config--m3u-file-tracks.el b/tests/test-music-config--m3u-file-tracks.el index badc9817..e3cbd72e 100644 --- a/tests/test-music-config--m3u-file-tracks.el +++ b/tests/test-music-config--m3u-file-tracks.el @@ -189,5 +189,23 @@ "Parse nil input returns nil gracefully." (should (null (cj/music--m3u-file-tracks nil)))) +;;; Non-music filtering + +(ert-deftest test-music-config--m3u-file-tracks-filters-non-music-local-files () + "Normal: a local non-music path (a saved cover.jpg line) is dropped; +music files and stream URLs pass through." + (test-music-config--m3u-file-tracks-setup) + (unwind-protect + (let* ((content (concat "/home/user/music/track1.mp3\n" + "/home/user/music/album/cover.jpg\n" + "https://somafm.com/stream\n" + "/home/user/music/track2.flac\n")) + (m3u-file (cj/create-temp-test-file-with-content content "test.m3u")) + (tracks (cj/music--m3u-file-tracks m3u-file))) + (should (equal tracks '("/home/user/music/track1.mp3" + "https://somafm.com/stream" + "/home/user/music/track2.flac")))) + (test-music-config--m3u-file-tracks-teardown))) + (provide 'test-music-config--m3u-file-tracks) ;;; test-music-config--m3u-file-tracks.el ends here diff --git a/tests/test-music-config--music-files-recursive.el b/tests/test-music-config--music-files-recursive.el new file mode 100644 index 00000000..f5f5fc5b --- /dev/null +++ b/tests/test-music-config--music-files-recursive.el @@ -0,0 +1,88 @@ +;;; test-music-config--music-files-recursive.el --- Tests for filtered directory collection -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Directory adds used to hand the whole tree to emms-add-directory-tree, +;; which adds every file it finds -- cover.jpg and friends ended up as +;; playlist rows. The filtered walk returns only files passing +;; cj/music--valid-file-p, skipping hidden dirs/files, sorted. Real temp-dir +;; fixtures; the EMMS boundary is mocked only in the command-level test. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defmacro test-music-files--with-fixture (var &rest body) + "Run BODY with VAR bound to a temp music-directory fixture." + (declare (indent 1)) + `(let ((,var (make-temp-file "music-test-" t))) + (unwind-protect + (progn + (make-directory (expand-file-name "album" ,var)) + (make-directory (expand-file-name ".hidden" ,var)) + (dolist (f '("song.mp3" "cover.jpg" "album/track.flac" + "album/folder.png" "album/notes.txt" + ".hidden/secret.mp3" ".stray.ogg")) + (write-region "" nil (expand-file-name f ,var))) + ,@body) + (delete-directory ,var t)))) + +;;; Normal Cases + +(ert-deftest test-music-files-recursive-music-only () + "Normal: only files with accepted music extensions come back, sorted; +cover art, text files, and hidden entries stay out." + (test-music-files--with-fixture root + (should (equal (mapcar (lambda (f) (file-relative-name f root)) + (cj/music--music-files-recursive root)) + '("album/track.flac" "song.mp3"))))) + +(ert-deftest test-music-add-directory-recursive-adds-only-music () + "Normal: the directory-add command feeds only music files to EMMS." + (test-music-files--with-fixture root + (let (added) + (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) + (lambda () (current-buffer))) + ((symbol-function 'emms-add-file) + (lambda (f) (push f added)))) + (cj/music-add-directory-recursive root)) + (should (equal (mapcar (lambda (f) (file-relative-name f root)) + (nreverse added)) + '("album/track.flac" "song.mp3")))))) + +;;; Boundary Cases + +(ert-deftest test-music-files-recursive-case-insensitive-extensions () + "Boundary: extensions match case-insensitively (Song.MP3 counts)." + (let ((root (make-temp-file "music-test-case-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "Song.MP3" root)) + (should (= 1 (length (cj/music--music-files-recursive root))))) + (delete-directory root t)))) + +(ert-deftest test-music-files-recursive-empty-directory () + "Boundary: a directory with no music files returns nil." + (let ((root (make-temp-file "music-test-empty-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "readme.txt" root)) + (should-not (cj/music--music-files-recursive root))) + (delete-directory root t)))) + +;;; Error Cases + +(ert-deftest test-music-add-directory-recursive-not-a-directory-errors () + "Error: a non-directory argument signals user-error." + (should-error (cj/music-add-directory-recursive "/nonexistent/nowhere") + :type 'user-error)) + +(provide 'test-music-config--music-files-recursive) +;;; test-music-config--music-files-recursive.el ends here diff --git a/tests/test-music-config--pin-point.el b/tests/test-music-config--pin-point.el new file mode 100644 index 00000000..2d6fa916 --- /dev/null +++ b/tests/test-music-config--pin-point.el @@ -0,0 +1,78 @@ +;;; test-music-config--pin-point.el --- Tests for the playlist gutter cursor -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The playlist cursor lives pinned at the start of the row (the number +;; gutter). The rows are rendered track lines, not editable text, and +;; vertical motion over thumbnails and stretch-space drifts point to +;; arbitrary visual columns (usually line end). A buffer-local +;; post-command snap enforces the model for every motion command. The one +;; exception is an active isearch, which owns point placement until it ends. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +;;; Normal Cases + +(ert-deftest test-music-pin-point-snaps-mid-line-to-bol () + "Normal: point mid-row snaps back to the beginning of the line." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-char 5) + (cj/music--pin-point-to-bol) + (should (bolp)) + (should (= (point) (point-min))))) + +(ert-deftest test-music-pin-point-noop-at-bol () + "Normal: point already at the row start stays put." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-line 1) + (let ((before (point))) + (cj/music--pin-point-to-bol) + (should (= (point) before))))) + +;;; Boundary Cases + +(ert-deftest test-music-pin-point-skips-during-isearch () + "Boundary: an active isearch owns point; the pin defers until it ends." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-char 5) + (let ((isearch-mode t)) + (cj/music--pin-point-to-bol)) + (should-not (bolp)))) + +(ert-deftest test-music-pin-point-empty-buffer-no-error () + "Boundary: an empty buffer is a no-op, no error." + (with-temp-buffer + (should-not (cj/music--pin-point-to-bol)) + (should (bolp)))) + +;;; Hook wiring + +(ert-deftest test-music-pin-point-ensure-wires-post-command-hook () + "Normal: the playlist buffer gets the pin on its buffer-local +post-command-hook." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--pin-point-to-bol post-command-hook)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--pin-point) +;;; test-music-config--pin-point.el ends here diff --git a/tests/test-music-config--playlist-dock.el b/tests/test-music-config--playlist-dock.el index 69d24cc3..1dbe9fbb 100644 --- a/tests/test-music-config--playlist-dock.el +++ b/tests/test-music-config--playlist-dock.el @@ -70,5 +70,45 @@ silently does nothing." (should-not (boundp 'cj/--music-playlist-width)) (should-not (fboundp 'cj/--music-playlist-side))) +(ert-deftest test-music-config-playlist-default-height-is-half () + "Normal: the dock opens at half the frame height by default (Craig, +2026-07-18 -- a third still read too short for a real playlist)." + (should (= cj/music-playlist-window-height 0.5))) + +(ert-deftest test-music-config-playlist-toggle-off-discards-shrunk-height () + "Error: a captured height below the default is discarded. Window churn +squeezes the dock, and remembering the squeeze reopens it too short on +every later toggle." + (let ((buffer (generate-new-buffer " *test-playlist-shrink*")) + (cj/--music-playlist-height nil)) + (unwind-protect + (save-window-excursion + (set-window-buffer (selected-window) buffer) + (let ((cj/music-playlist-buffer-name (buffer-name buffer))) + (cl-letf (((symbol-function 'cj/side-window-capture-size) + (lambda (_w _side var) (set var 0.2))) + ((symbol-function 'delete-window) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/music-playlist-toggle))) + (should (null cj/--music-playlist-height))) + (kill-buffer buffer)))) + +(ert-deftest test-music-config-playlist-toggle-off-keeps-enlarged-height () + "Normal: a captured height at or above the default is remembered, so a +deliberate enlargement sticks for the session." + (let ((buffer (generate-new-buffer " *test-playlist-grow*")) + (cj/--music-playlist-height nil)) + (unwind-protect + (save-window-excursion + (set-window-buffer (selected-window) buffer) + (let ((cj/music-playlist-buffer-name (buffer-name buffer))) + (cl-letf (((symbol-function 'cj/side-window-capture-size) + (lambda (_w _side var) (set var 0.5))) + ((symbol-function 'delete-window) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/music-playlist-toggle))) + (should (= 0.5 cj/--music-playlist-height))) + (kill-buffer buffer)))) + (provide 'test-music-config--playlist-dock) ;;; test-music-config--playlist-dock.el ends here diff --git a/tests/test-music-config--playlist-open-position.el b/tests/test-music-config--playlist-open-position.el new file mode 100644 index 00000000..cd83e65b --- /dev/null +++ b/tests/test-music-config--playlist-open-position.el @@ -0,0 +1,147 @@ +;;; test-music-config--playlist-open-position.el --- Tests for playlist landing position -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Opening the playlist lands point by one rule: the beginning of the playing +;; track's line when a song is playing, else the top of the list. The old +;; behavior keyed off EMMS's selected track, which stays set while stopped, so +;; the playlist opened deep in the list at a stale position. The decision is +;; a pure helper; the window landing (point + upper-third recenter) is tested +;; with recenter stubbed at the display boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +;; Declare the emms vars special HERE too: the module's bare (defvar +;; emms-player-playing-p) marks them special only for code compiled in +;; that file, so a plain `let' in this lexical-binding test file would +;; bind them lexically and the module would never see the value (the +;; scope-shadowing trap from the testing rules). +(defvar emms-player-playing-p) +(defvar emms-playlist-selected-marker) + +(require 'music-config) + +(defmacro test-music-open-pos--with-buffer (var &rest body) + "Run BODY with VAR bound to a temp 3-track playlist-shaped buffer." + (declare (indent 1)) + `(let ((,var (generate-new-buffer " *test-open-pos*"))) + (unwind-protect + (progn + (with-current-buffer ,var + (insert "track one\ntrack two\ntrack three\n")) + ,@body) + (when (buffer-live-p ,var) (kill-buffer ,var))))) + +(defun test-music-open-pos--marker (buffer line offset) + "Marker in BUFFER at LINE (1-based) plus OFFSET chars." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (forward-char offset) + (point-marker)))) + +;;; Normal Cases + +(ert-deftest test-music-playlist-open-position-playing-lands-on-playing-line-start () + "Normal: playing -> the playing track's line, at its beginning (even when +the marker sits mid-line)." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 2 4))) + (should (= (cj/music--playlist-open-position buf) + (with-current-buffer buf + (save-excursion (goto-char (point-min)) (forward-line 1) (point)))))))) + +(ert-deftest test-music-playlist-open-position-stopped-lands-at-top () + "Normal: not playing -> top of the list, even though EMMS still has a +stale selected track." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 3 0))) + (should (= (cj/music--playlist-open-position buf) 1))))) + +;;; Boundary Cases + +(ert-deftest test-music-playlist-open-position-playing-no-marker-lands-at-top () + "Boundary: playing but no usable marker -> top of the list." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker nil)) + (should (= (cj/music--playlist-open-position buf) 1))))) + +(ert-deftest test-music-playlist-open-position-marker-in-other-buffer-lands-at-top () + "Boundary: a marker pointing into a different buffer is ignored." + (test-music-open-pos--with-buffer buf + (with-temp-buffer + (insert "elsewhere\n") + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (point-marker))) + (should (= (cj/music--playlist-open-position buf) 1)))))) + +(ert-deftest test-music-playlist-open-position-empty-buffer () + "Boundary: an empty playlist lands at point-min without error." + (let ((buf (generate-new-buffer " *test-open-pos-empty*"))) + (unwind-protect + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker nil)) + (should (= (cj/music--playlist-open-position buf) 1))) + (kill-buffer buf)))) + +;;; Landing (window boundary stubbed) + +(ert-deftest test-music-playlist-land-point-playing-recenter-upper-third () + "Normal: landing on a playing row sets window point to its line start and +recenters into the upper third." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 2 4)) + (recenter-arg 'not-called)) + (save-window-excursion + (set-window-buffer (selected-window) buf) + (cl-letf (((symbol-function 'recenter) + (lambda (&optional arg &rest _) (setq recenter-arg arg)))) + (cj/music--playlist-land-point (selected-window) buf)) + (should (= (window-point (selected-window)) + (with-current-buffer buf + (save-excursion (goto-char (point-min)) (forward-line 1) (point))))) + (should (integerp recenter-arg)) + (should (>= recenter-arg 1)))))) + +(ert-deftest test-music-playlist-land-point-stopped-top-no-recenter () + "Normal: landing while stopped puts window point at the top; no recenter." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker nil) + (recenter-called nil)) + (save-window-excursion + (set-window-buffer (selected-window) buf) + (cl-letf (((symbol-function 'recenter) + (lambda (&rest _) (setq recenter-called t)))) + (cj/music--playlist-land-point (selected-window) buf)) + (should (= (window-point (selected-window)) 1)) + (should-not recenter-called))))) + +;;; hl-line in the playlist buffer + +(ert-deftest test-music-playlist-ensure-enables-hl-line () + "Normal: the playlist buffer gets hl-line-mode so the current row is +findable even when the cursor sits on album art." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should hl-line-mode))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--playlist-open-position) +;;; test-music-config--playlist-open-position.el ends here diff --git a/tests/test-music-config--radio-tags.el b/tests/test-music-config--radio-tags.el new file mode 100644 index 00000000..60e1c9d8 --- /dev/null +++ b/tests/test-music-config--radio-tags.el @@ -0,0 +1,79 @@ +;;; test-music-config--radio-tags.el --- Tests for radio-browser tag pre-population -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The tag-search prompt completes over the popular tags fetched from +;; radio-browser's /json/tags endpoint (cached per session). These tests cover +;; the pure pieces: the endpoint URL, the parse (trim + drop-empty + dedupe, +;; since the source data is user-generated and dirty), and the session cache. +;; The network GET is mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defconst test-music-radio-tags--fixture + (concat "[{\"name\":\"jazz \",\"stationcount\":300}," + "{\"name\":\" jazz\",\"stationcount\":5}," + "{\"name\":\"\",\"stationcount\":2}," + "{\"name\":\"rock\",\"stationcount\":100}]") + "A recorded /json/tags response with whitespace, empty, and duplicate names.") + +;;; Normal Cases + +(ert-deftest test-music-radio-tags-url-shape () + "Normal: the tags URL targets /json/tags ordered by station count with the limit." + (let* ((cj/music-radio-tag-limit 500) + (u (cj/music-radio--tags-url "de1.api.radio-browser.info"))) + (should (string-match-p "/json/tags" u)) + (should (string-match-p "order=stationcount" u)) + (should (string-match-p "limit=500" u)))) + +(ert-deftest test-music-radio-parse-tags-trims-dedupes-drops-empty () + "Normal: tag names come back trimmed, deduped, and without empties." + (should (equal (cj/music-radio--parse-tags test-music-radio-tags--fixture) + '("jazz" "rock")))) + +(ert-deftest test-music-radio-available-tags-caches-per-session () + "Normal: the fetch runs once; later calls serve the cache." + (let ((cj/music-radio--tags-cache nil) + (calls 0)) + (cl-letf (((symbol-function 'cj/music-radio--http-get) + (lambda (_url) (cl-incf calls) test-music-radio-tags--fixture))) + (should (equal (cj/music-radio--available-tags) '("jazz" "rock"))) + (should (equal (cj/music-radio--available-tags) '("jazz" "rock"))) + (should (= calls 1))))) + +;;; Boundary Cases + +(ert-deftest test-music-radio-parse-tags-empty-array () + "Boundary: an empty tag array parses to nil." + (should-not (cj/music-radio--parse-tags "[]"))) + +;;; Error Cases + +(ert-deftest test-music-radio-available-tags-fetch-failure-returns-nil-and-retries () + "Error: a failed fetch yields nil, leaves the cache empty, and retries next call." + (let ((cj/music-radio--tags-cache nil) + (calls 0)) + (cl-letf (((symbol-function 'cj/music-radio--http-get) + (lambda (_url) (cl-incf calls) nil))) + (should-not (cj/music-radio--available-tags)) + (should-not cj/music-radio--tags-cache) + (should-not (cj/music-radio--available-tags)) + (should (= calls 2))))) + +(ert-deftest test-music-radio-parse-tags-malformed-user-errors () + "Error: a non-JSON body signals user-error, not a raw parse error." + (should-error (cj/music-radio--parse-tags "<html>502</html>") + :type 'user-error)) + +(provide 'test-music-config--radio-tags) +;;; test-music-config--radio-tags.el ends here diff --git a/tests/test-music-config--radio.el b/tests/test-music-config--radio.el index 3923a599..a91612bf 100644 --- a/tests/test-music-config--radio.el +++ b/tests/test-music-config--radio.el @@ -19,6 +19,10 @@ (defvar cj/custom-keymap (make-sparse-keymap) "Stub keymap for testing.") +;; Declare special here too (the module's bare defvar is file-local) so the +;; registration test's `let' binds dynamically. +(defvar marginalia-annotator-registry) + (require 'music-config) (declare-function cj/music-radio--parse-search "music-config" (json-text)) @@ -134,5 +138,70 @@ (should (= (length cands) 2)) (should (= (length (delete-dups (copy-sequence keys))) 2)))) +;;; --------------------------- query whitespace -------------------------------- + +(ert-deftest test-music-radio-search-and-play-trims-query () + "Normal: surrounding whitespace on the query is stripped before the search. +A trailing space in the minibuffer otherwise reaches the API as %20 and +matches nothing." + (let (captured) + (cl-letf (((symbol-function 'cj/emms--setup) #'ignore) + ((symbol-function 'cj/music-radio--search) + (lambda (query _field) (setq captured query) nil))) + (should-error (cj/music-radio--search-and-play " jazz " "tag") + :type 'user-error)) + (should (equal captured "jazz")))) + +(ert-deftest test-music-radio-search-and-play-whitespace-only-no-search () + "Error: a whitespace-only query errors out before any network search." + (let (searched) + (cl-letf (((symbol-function 'cj/emms--setup) #'ignore) + ((symbol-function 'cj/music-radio--search) + (lambda (&rest _) (setq searched t) nil))) + (should-error (cj/music-radio--search-and-play " " "tag") + :type 'user-error)) + (should-not searched))) + +;;; --------------------------- column alignment -------------------------------- + +(ert-deftest test-music-radio-format-candidate-votes-column-fixed-width () + "Normal: the votes field pads to a fixed width so the tags column aligns +across stations with different vote counts." + (let* ((low (cj/music-radio--format-candidate + '(:codec "MP3" :bitrate 128 :countrycode "US" :votes 7 :tags "jazz"))) + (high (cj/music-radio--format-candidate + '(:codec "MP3" :bitrate 128 :countrycode "US" :votes 174208 :tags "jazz")))) + (should (= (string-match "jazz" low) (string-match "jazz" high))))) + +(ert-deftest test-music-radio-completion-table-annotates-station () + "Normal: the table's annotation function returns the Variant-B string for +a station candidate (marginalia handles the right-alignment)." + (let* ((candidates '(("Jazz FM" . (:codec "MP3" :bitrate 128 :countrycode "US" + :votes 5 :tags "jazz")))) + (table (cj/music-radio--completion-table candidates)) + (meta (funcall table "" nil 'metadata)) + (annotate (alist-get 'annotation-function (cdr meta)))) + (should (functionp annotate)) + (should-not (alist-get 'affixation-function (cdr meta))) + (should (string-match-p "MP3" (funcall annotate "Jazz FM"))) + (should (string-match-p "jazz" (funcall annotate "Jazz FM"))))) + +(ert-deftest test-music-radio-completion-table-done-sentinel-no-annotation () + "Boundary: the [done] sentinel has no station and annotates as nil." + (let* ((candidates '(("[done]") ("Station" . (:codec "MP3" :bitrate 128 + :countrycode "US" :votes 1 :tags "x")))) + (table (cj/music-radio--completion-table candidates)) + (annotate (alist-get 'annotation-function + (cdr (funcall table "" nil 'metadata))))) + (should-not (funcall annotate "[done]")))) + +(ert-deftest test-music-radio-completion-table-registers-with-marginalia () + "Normal: building the table registers cj-radio-station so marginalia +right-aligns the table's own annotations." + (let ((marginalia-annotator-registry '())) + (cj/music-radio--completion-table '(("X" . (:codec "MP3")))) + (should (equal (assq 'cj-radio-station marginalia-annotator-registry) + '(cj-radio-station builtin none))))) + (provide 'test-music-config--radio) ;;; test-music-config--radio.el ends here diff --git a/tests/test-music-config--renumber-rows.el b/tests/test-music-config--renumber-rows.el new file mode 100644 index 00000000..d5bc5141 --- /dev/null +++ b/tests/test-music-config--renumber-rows.el @@ -0,0 +1,232 @@ +;;; test-music-config--renumber-rows.el --- Tests for playlist row numbering -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Playlist rows carry a numeric overlay prefix so the cursor stays visible +;; when it sits on a cover-art thumbnail and each row's position in the list +;; is readable. The renumber walks the buffer and rebuilds the overlays; a +;; buffer-local after-change hook debounces it behind an idle timer. Overlays +;; leave the buffer text untouched (EMMS owns it), so these tests drive plain +;; temp buffers. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defun test-music-renumber--numbers (buffer) + "Return the overlay number strings in BUFFER, in position order." + (with-current-buffer buffer + (mapcar (lambda (ov) (overlay-get ov 'before-string)) + (sort (seq-filter (lambda (ov) (overlay-get ov 'cj-music-row-number)) + (overlays-in (point-min) (point-max))) + (lambda (a b) (< (overlay-start a) (overlay-start b))))))) + +;;; Normal Cases + +(ert-deftest test-music-renumber-rows-numbers-each-line () + "Normal: every non-blank line gets a sequential number overlay." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\n") + (cj/music--renumber-rows (current-buffer)) + (should (equal (mapcar #'substring-no-properties + (test-music-renumber--numbers (current-buffer))) + '(" 1 " " 2 " " 3 "))))) + +(ert-deftest test-music-renumber-rows-idempotent () + "Normal: renumbering twice leaves one overlay per line, not two." + (with-temp-buffer + (insert "track one\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (cj/music--renumber-rows (current-buffer)) + (should (= 2 (length (test-music-renumber--numbers (current-buffer))))))) + +(ert-deftest test-music-renumber-rows-number-carries-cursor-property () + "Normal: the number string carries a cursor property. Point is pinned at +the row start, and without the property redisplay draws the cursor after +the before-string -- on the album-art thumbnail, where it's invisible." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (let ((s (car (test-music-renumber--numbers (current-buffer))))) + (should (get-text-property 0 'cursor s))))) + +;;; Boundary Cases + +(ert-deftest test-music-renumber-rows-skips-blank-lines () + "Boundary: blank lines are not numbered and don't advance the count." + (with-temp-buffer + (insert "track one\n\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (should (equal (mapcar #'substring-no-properties + (test-music-renumber--numbers (current-buffer))) + '(" 1 " " 2 "))))) + +(ert-deftest test-music-renumber-rows-empty-buffer-no-overlays () + "Boundary: an empty buffer gets no overlays and no error." + (with-temp-buffer + (cj/music--renumber-rows (current-buffer)) + (should-not (test-music-renumber--numbers (current-buffer))))) + +;;; Error Cases + +(ert-deftest test-music-renumber-rows-dead-buffer-noop () + "Error: renumbering a killed buffer is a silent no-op (the debounce timer +can fire after the playlist buffer is gone)." + (let ((buf (generate-new-buffer " *test-renumber-dead*"))) + (kill-buffer buf) + (should-not (cj/music--renumber-rows buf)))) + +(ert-deftest test-music-renumber-rows-number-outranks-header-overlay () + "Normal: number overlays carry a priority above the header overlay's 100. +The header block is a same-position overlay string at the buffer start; +without the higher priority, row 1's number renders above the header +instead of next to its own track." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (let ((ov (car (seq-filter (lambda (o) (overlay-get o 'cj-music-row-number)) + (overlays-in (point-min) (point-max)))))) + (should (> (or (overlay-get ov 'priority) 0) 100))))) + +(ert-deftest test-music-ensure-playlist-buffer-logical-line-motion () + "Normal: the playlist moves by logical lines, not screen lines. The +multi-line header overlay string at position 1 otherwise absorbs every +next-line from the top row -- vertical motion steps through the header's +display and maps back to the same buffer position, so arrows look dead." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (local-variable-p 'line-move-visual)) + (should-not line-move-visual))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Current-row indicator + +(ert-deftest test-music-highlight-current-number-marks-current-row () + "Normal: the current row's number renders inverse-video; moving to another +row restores the old one and marks the new one. The block cursor only +draws in the selected window, so the number itself carries the mark." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (forward-line 1) + (cj/music--highlight-current-number) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should-not (plist-get (get-text-property 0 'face (nth 0 numbers)) :inverse-video)) + (should (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video))) + (forward-line 1) + (cj/music--highlight-current-number) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should-not (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video)) + (should (plist-get (get-text-property 0 'face (nth 2 numbers)) :inverse-video))))) + +(ert-deftest test-music-highlight-current-number-survives-renumber () + "Boundary: a renumber rebuilds the overlays; the highlight re-applies to +the current row rather than pointing at a dead overlay." + (with-temp-buffer + (insert "track one\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (forward-line 1) + (cj/music--highlight-current-number) + (cj/music--renumber-rows (current-buffer)) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video))))) + +(ert-deftest test-music-highlight-current-number-keeps-cursor-property () + "Boundary: re-facing a number keeps the cursor property intact." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (cj/music--highlight-current-number) + (let ((s (car (test-music-renumber--numbers (current-buffer))))) + (should (get-text-property 0 'cursor s))))) + +(ert-deftest test-music-ensure-playlist-buffer-sticky-hl-line () + "Normal: hl-line in the playlist stays visible when the window isn't +selected -- the dock is glanced at from other windows constantly." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (should (buffer-local-value 'hl-line-sticky-flag created))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Sticky header + +(ert-deftest test-music-stick-header-moves-overlay-to-window-start () + "Normal: a scroll re-anchors the header overlay at the new window start, +so the header block stays at the top of the window while the list scrolls." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\ntrack four\n") + (setq cj/music--header-overlay (make-overlay (point-min) (point-min))) + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (let ((start (save-excursion (goto-char (point-min)) (forward-line 2) (point)))) + (cj/music--stick-header (selected-window) start) + (should (= (overlay-start cj/music--header-overlay) start)) + ;; Converges: the same start again is a no-op, not a loop. + (cj/music--stick-header (selected-window) start) + (should (= (overlay-start cj/music--header-overlay) start)))))) + +(ert-deftest test-music-stick-header-no-overlay-noop () + "Boundary: no header overlay yet -- the scroll handler is a silent no-op." + (with-temp-buffer + (insert "track one\n") + (setq cj/music--header-overlay nil) + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (should-not (cj/music--stick-header (selected-window) (point-min)))))) + +(ert-deftest test-music-header-anchor-position-displayed-vs-not () + "Normal: the header anchors at the displaying window's start; an +undisplayed buffer anchors at the top." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\ntrack four\n") + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (let ((start (save-excursion (goto-char (point-min)) (forward-line 2) (point)))) + (set-window-start (selected-window) start) + (should (= (cj/music--header-anchor-position) start)))) + ;; Not displayed after the excursion restores the old config. + (should (= (cj/music--header-anchor-position) (point-min))))) + +(ert-deftest test-music-ensure-playlist-buffer-wires-scroll-hook () + "Normal: the playlist buffer re-sticks its header on every window scroll." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--stick-header window-scroll-functions)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Hook wiring + +(ert-deftest test-music-renumber-ensure-playlist-buffer-wires-hook () + "Normal: the playlist buffer gets the debounced renumber on after-change." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--schedule-renumber after-change-functions)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--renumber-rows) +;;; test-music-config--renumber-rows.el ends here diff --git a/tests/test-music-config-commands.el b/tests/test-music-config-commands.el index 3c585d0b..40fb2d81 100644 --- a/tests/test-music-config-commands.el +++ b/tests/test-music-config-commands.el @@ -30,17 +30,21 @@ ;;; cj/music-add-directory-recursive (ert-deftest test-music-add-directory-recursive-passes-dir-to-emms () - "Normal: add-directory-recursive routes through emms-add-directory-tree." + "Normal: add-directory-recursive feeds the directory's music files (and +only those) to emms-add-file -- the raw-tree path added cover art too." (let* ((tmp (file-name-as-directory (make-temp-file "cj-music-add-" t))) - called) + added) (unwind-protect - (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) #'ignore) - ((symbol-function 'emms-add-directory-tree) - (lambda (dir) (setq called dir))) - ((symbol-function 'message) #'ignore)) - (cj/music-add-directory-recursive tmp)) + (progn + (write-region "" nil (expand-file-name "song.mp3" tmp)) + (write-region "" nil (expand-file-name "cover.jpg" tmp)) + (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) #'ignore) + ((symbol-function 'emms-add-file) + (lambda (f) (push f added))) + ((symbol-function 'message) #'ignore)) + (cj/music-add-directory-recursive tmp))) (delete-directory tmp t)) - (should (equal called tmp)))) + (should (equal (mapcar #'file-name-nondirectory added) '("song.mp3"))))) (ert-deftest test-music-add-directory-recursive-errors-on-non-directory () "Error: passing a regular file (not a directory) signals user-error." diff --git a/tests/test-music-config-create-radio-station.el b/tests/test-music-config-create-radio-station.el index 7d9adbed..4f49f49b 100644 --- a/tests/test-music-config-create-radio-station.el +++ b/tests/test-music-config-create-radio-station.el @@ -106,15 +106,16 @@ (ert-deftest test-music-config-menu-map-lowercase-keys () "Normal: the menu's former uppercase keys live on lowercase homes, and the -playlist buffer saves on v." +playlist buffer saves on s (single on 1, old save key v unbound)." (should (eq (lookup-key cj/music-map "v") 'cj/music-playlist-show)) (should (eq (lookup-key cj/music-map "u") 'emms-shuffle)) (should (eq (lookup-key cj/music-map "l") 'emms-toggle-repeat-playlist)) (should-not (lookup-key cj/music-map "R")) (should-not (lookup-key cj/music-map "M")) (should-not (lookup-key cj/music-map "Z")) - (should (eq (lookup-key emms-playlist-mode-map "v") 'cj/music-playlist-save)) - (should-not (eq (lookup-key emms-playlist-mode-map "w") 'cj/music-playlist-save))) + (should (eq (lookup-key emms-playlist-mode-map "s") 'cj/music-playlist-save)) + (should (eq (lookup-key emms-playlist-mode-map "1") 'emms-toggle-repeat-track)) + (should-not (lookup-key emms-playlist-mode-map "v"))) ;;; Error Cases diff --git a/tests/test-music-config-helpers-untested.el b/tests/test-music-config-helpers-untested.el index bfdb2634..87aa210c 100644 --- a/tests/test-music-config-helpers-untested.el +++ b/tests/test-music-config-helpers-untested.el @@ -154,17 +154,18 @@ test prelude inserts filler with `inhibit-read-only' bound." ;;; ---------- cj/music-add-directory-recursive ---------- (ert-deftest test-mc-add-directory-recursive-normal-calls-emms () - "Normal: with an existing directory, the recursive add reaches emms." + "Normal: with an existing directory, the recursive add reaches emms with +each music file individually (the filtered walk, not the raw tree)." (test-mc-untested--setup) (unwind-protect (let* ((dir cj/test-base-dir) - (called-with nil)) - (cl-letf (((symbol-function 'emms-add-directory-tree) - (lambda (d) (setq called-with d))) + (added nil)) + (write-region "" nil (expand-file-name "one.mp3" dir)) + (cl-letf (((symbol-function 'emms-add-file) + (lambda (f) (push f added))) ((symbol-function 'message) #'ignore)) (cj/music-add-directory-recursive dir)) - (should (equal (file-name-as-directory called-with) - (file-name-as-directory dir)))) + (should (member "one.mp3" (mapcar #'file-name-nondirectory added)))) (test-mc-untested--teardown))) (ert-deftest test-mc-add-directory-recursive-error-not-a-directory () diff --git a/tests/test-nov-reading--config-defaults.el b/tests/test-nov-reading--config-defaults.el index 5e454ce1..ff52d8f5 100644 --- a/tests/test-nov-reading--config-defaults.el +++ b/tests/test-nov-reading--config-defaults.el @@ -16,6 +16,8 @@ (declare-function cj/nov--next-reading-palette "nov-reading" (current names)) (defvar cj/nov-reading-palettes) (defvar cj/nov-reading-default-palette) +(defvar cj/nov-reading-profile) +(defvar cj/nov--typography-remap-cookies) (ert-deftest test-nov-reading-config-default-is-dark () "Normal: a fresh nov buffer opens on the dark palette." @@ -34,5 +36,32 @@ (should-not (cj/nov--next-reading-palette "light" names)) (should (equal (cj/nov--next-reading-palette nil names) "dark")))) +(ert-deftest test-nov-reading-config-uses-reading-font-profile () + "Normal: nov typography names the shared Reading profile." + (should (eq cj/nov-reading-profile 'reading))) + +(ert-deftest test-nov-reading-depends-on-pure-profile-layer () + "Boundary: loading nov shares profile data without loading Fontaine config." + (should (featurep 'font-profiles)) + (should-not (featurep 'font-config))) + +(ert-deftest test-nov-reading-typography-remaps-shared-profile-locally () + "Normal: nov applies Reading locally at its own base height without stacking." + (let ((cj/nov--typography-remap-cookies '(old-default old-fixed)) + (removed nil) + (applied nil)) + (cl-letf (((symbol-function 'face-remap-remove-relative) + (lambda (cookie) (push cookie removed))) + ((symbol-function 'cj/font-profile-remap-buffer) + (lambda (profile height) + (setq applied (list profile height)) + '(new-default new-fixed)))) + (cj/nov-reading-apply-typography)) + (should (equal applied '(reading 180))) + (should (equal (sort removed #'string-lessp) + '(old-default old-fixed))) + (should (equal cj/nov--typography-remap-cookies + '(new-default new-fixed))))) + (provide 'test-nov-reading--config-defaults) ;;; test-nov-reading--config-defaults.el ends here diff --git a/tests/test-org-agenda-config-commands.el b/tests/test-org-agenda-config-commands.el index 76407439..139bf90f 100644 --- a/tests/test-org-agenda-config-commands.el +++ b/tests/test-org-agenda-config-commands.el @@ -176,5 +176,89 @@ large), so the standalone OVERDUE section was redundant." (should (string-match-p "<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} 09:00>" text))))) +(ert-deftest test-org-agenda-add-timestamp-preserves-point-and-following-line () + "Normal: the stamp lands between the entry and the next line, point unmoved. +The docstring promises the event appears \"underneath the line-at-point\", +so neither the entry nor whatever follows it may be disturbed." + (with-temp-buffer + (insert "* First\n* Second") + (goto-char (point-min)) + (let ((start (progn (org-end-of-line) (point)))) + (goto-char (point-min)) + (cj/add-timestamp-to-org-entry "09:00") + ;; Point is left at the end of the entry it stamped. + (should (= (point) start))) + (let ((lines (split-string (buffer-string) "\n"))) + (should (equal (nth 0 lines) "* First")) + (should (string-match-p "\\`<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} 09:00>\\'" + (nth 1 lines))) + (should (equal (nth 2 lines) "* Second"))))) + +(ert-deftest test-org-agenda-add-timestamp-empty-time-string () + "Boundary: an empty time yields a bare date stamp with a trailing space. +Characterizes current behavior -- the separator space is unconditional, so +an empty S produces `<DATE >' rather than `<DATE>'. Harmless in an agenda +\(org reads the date\), and pinned here so a future format change is a +deliberate one." + (with-temp-buffer + (insert "* Heading here") + (goto-char (point-min)) + (cj/add-timestamp-to-org-entry "") + (should (string-match-p "<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} >" + (buffer-string))))) + +(ert-deftest test-org-agenda-add-timestamp-unicode-time-string () + "Boundary: non-ASCII in S survives into the stamp uncorrupted." + (with-temp-buffer + (insert "* Heading here") + (goto-char (point-min)) + (cj/add-timestamp-to-org-entry "09:00 café ☕") + (should (string-match-p "09:00 café ☕>" (buffer-string))))) + +(ert-deftest test-org-agenda-add-timestamp-empty-buffer () + "Boundary: an empty buffer still gets a stamp rather than signalling. +`org-end-of-line' and `open-line' both no-op safely at point-min." + (with-temp-buffer + (cj/add-timestamp-to-org-entry "09:00") + (should (string-match-p "<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} 09:00>" + (buffer-string))))) + +(ert-deftest test-org-agenda-add-timestamp-read-only-buffer-signals () + "Error: a read-only buffer signals rather than silently dropping the stamp." + (with-temp-buffer + (insert "* Heading") + (goto-char (point-min)) + (setq buffer-read-only t) + (should-error (cj/add-timestamp-to-org-entry "09:00") :type 'buffer-read-only))) + +(defconst test-org-agenda--timeformat-special-at-load + (special-variable-p 'cj/timeformat) + "Whether `cj/timeformat' was special immediately after loading the module. +Captured here at load, before any test body runs, because the fact under +test is destroyed by observing it late: calling +`cj/add-timestamp-to-org-entry' once would execute a `defvar' nested in the +defun and make the symbol special retroactively. ERT runs tests +alphabetically, so an in-test `special-variable-p' check passes on the +strength of whichever test ran first -- green in a full-file run, red in +isolation. Snapshotting at load makes the guard order-independent.") + +(ert-deftest test-org-agenda-timeformat-is-a-top-level-special-variable () + "Normal: `cj/timeformat' is special and bound at load, not first call. +It used to be `defvar'd inside `cj/add-timestamp-to-org-entry', so it was +unbound until the command ran once and a `let' around the call bound it +lexically instead of dynamically. Pinning both halves of the fix: the +symbol is special at load time, and rebinding it actually reaches the +command." + (should test-org-agenda--timeformat-special-at-load) + (should (equal (default-value 'cj/timeformat) "%Y-%m-%d %a")) + ;; The dynamic binding must reach the insertion. + (with-temp-buffer + (insert "* Heading") + (goto-char (point-min)) + (let ((cj/timeformat "%Y")) + (cj/add-timestamp-to-org-entry "09:00")) + (should (string-match-p "\\`<[0-9]\\{4\\} 09:00>\\'" + (nth 1 (split-string (buffer-string) "\n")))))) + (provide 'test-org-agenda-config-commands) ;;; test-org-agenda-config-commands.el ends here diff --git a/tests/test-org-agenda-frame.el b/tests/test-org-agenda-frame.el new file mode 100644 index 00000000..167cf2ff --- /dev/null +++ b/tests/test-org-agenda-frame.el @@ -0,0 +1,1167 @@ +;;; test-org-agenda-frame.el --- Tests for the fullscreen agenda frame -*- lexical-binding: t; -*- + +;;; Commentary: +;; Phase 1 of the org-agenda fullscreen frame (spec: +;; docs/specs/2026-07-17-org-agenda-fullscreen-frame-spec.org). Frame lookup +;; is mocked (frame-list / frame-live-p / frame-parameter), the house pattern +;; from test-dirvish-config-popup.el, since --batch can't create real frames. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-agenda-frame) + +;; org-agenda isn't loaded in batch (no package-initialize), so declare the +;; command list special and bound for the registration tests to let-bind. +(defvar org-agenda-custom-commands nil) + +;;; cj/--agenda-frame — locate the marked frame + +(ert-deftest test-org-agenda-frame-find-returns-marked-live-frame () + "Normal: returns the live frame carrying the `cj/agenda-frame' marker." + (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) (and (eq p 'cj/agenda-frame) (eq f 'fb))))) + (should (eq (cj/--agenda-frame) 'fb)))) + +(ert-deftest test-org-agenda-frame-find-nil-when-none-marked () + "Boundary: no frame carries the marker -> 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) nil))) + (should (null (cj/--agenda-frame))))) + +(ert-deftest test-org-agenda-frame-find-ignores-dead-marked-frame () + "Error: a marked but dead frame is not returned." + (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) (and (eq p 'cj/agenda-frame) (eq f 'fb))))) + (should (null (cj/--agenda-frame))))) + +;;; cj/--agenda-frame-p — is FRAME a live agenda frame + +(ert-deftest test-org-agenda-frame-p-true-for-live-marked () + "Normal: a live marked frame is an agenda frame." + (cl-letf (((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) + (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'fa))))) + (should (cj/--agenda-frame-p 'fa)))) + +(ert-deftest test-org-agenda-frame-p-nil-for-unmarked () + "Boundary: a live unmarked frame is not an agenda frame." + (cl-letf (((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) (lambda (_f _p) nil))) + (should (null (cj/--agenda-frame-p 'fa))))) + +(ert-deftest test-org-agenda-frame-p-nil-for-dead-marked () + "Error: a dead marked frame is not an agenda frame." + (cl-letf (((symbol-function 'frame-live-p) (lambda (_f) nil)) + ((symbol-function 'frame-parameter) + (lambda (_f p) (eq p 'cj/agenda-frame)))) + (should (null (cj/--agenda-frame-p 'fa))))) + +;;; cj/--agenda-frame-working-frame — route source files to a non-agenda frame + +(ert-deftest test-org-agenda-working-frame-returns-non-agenda-frame () + "Normal: with no recorded launch frame, returns the first live non-agenda frame." + (let ((cj/--agenda-frame-launch-frame nil)) + (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda work))) + ((symbol-function 'frame-live-p) (lambda (f) (memq f '(agenda work)))) + ((symbol-function 'frame-parameter) + (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) + (should (eq (cj/--agenda-frame-working-frame) 'work))))) + +(ert-deftest test-org-agenda-working-frame-prefers-live-launch-frame () + "Normal: the recorded launch frame wins when live and non-agenda." + (let ((cj/--agenda-frame-launch-frame 'w2)) + (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda w1 w2))) + ((symbol-function 'frame-live-p) (lambda (f) (memq f '(agenda w1 w2)))) + ((symbol-function 'frame-parameter) + (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) + (should (eq (cj/--agenda-frame-working-frame) 'w2))))) + +(ert-deftest test-org-agenda-working-frame-falls-back-when-launch-dead () + "Boundary: a dead recorded launch frame falls back to another non-agenda frame." + (let ((cj/--agenda-frame-launch-frame 'gone)) + (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda work))) + ((symbol-function 'frame-live-p) (lambda (f) (memq f '(agenda work)))) + ((symbol-function 'frame-parameter) + (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) + (should (eq (cj/--agenda-frame-working-frame) 'work))))) + +(ert-deftest test-org-agenda-working-frame-nil-when-only-agenda () + "Error: the agenda frame is the only live frame -> nil (caller creates one)." + (let ((cj/--agenda-frame-launch-frame nil)) + (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda))) + ((symbol-function 'frame-live-p) (lambda (f) (eq f 'agenda))) + ((symbol-function 'frame-parameter) + (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) + (should (null (cj/--agenda-frame-working-frame)))))) + +;;; cj/--agenda-frame-command — the dedicated F seven-day view + +(defun test-org-agenda-frame--block-settings () + "Return the per-block settings alist of the agenda-frame command." + (let* ((cmd (cj/--agenda-frame-command)) + (blocks (nth 2 cmd)) + (agenda-block (car blocks))) + (nth 2 agenda-block))) + +(defun test-org-agenda-frame--general-settings () + "Return the general (view-wide) settings alist of the agenda-frame command." + (nth 3 (cj/--agenda-frame-command))) + +(ert-deftest test-org-agenda-frame-command-key-is-F () + "Normal: the command's key is F (collision-free with the existing d)." + (should (equal (nth 0 (cj/--agenda-frame-command)) "F"))) + +(ert-deftest test-org-agenda-frame-command-today-anchored-7-day () + "Normal: the default span is seven days anchored to today, not Monday. +The span is the frame-span variable (default 7), evaluated the way org +evaluates custom-command settings." + (let ((s (test-org-agenda-frame--block-settings))) + (should (equal (default-value 'cj/--agenda-frame-span) 7)) + (should (equal (eval (cadr (assq 'org-agenda-span s)) t) + (default-value 'cj/--agenda-frame-span))) + (should (equal (cadr (assq 'org-agenda-start-day s)) "0d")) + ;; start-on-weekday nil is what un-anchors the span from Monday. + (should (assq 'org-agenda-start-on-weekday s)) + (should (null (cadr (assq 'org-agenda-start-on-weekday s)))))) + +(ert-deftest test-org-agenda-frame-command-span-follows-variable () + "Normal: the block span reads `cj/--agenda-frame-span', so d/w can change it +and a redo -- which re-evaluates the lprops -- picks up the new span." + (let ((cj/--agenda-frame-span 1)) + (should (equal (eval (cadr (assq 'org-agenda-span + (test-org-agenda-frame--block-settings))) + t) + 1))) + (let ((cj/--agenda-frame-span 7)) + (should (equal (eval (cadr (assq 'org-agenda-span + (test-org-agenda-frame--block-settings))) + t) + 7)))) + +(ert-deftest test-org-agenda-frame-day-view-sets-span-1-and-redoes () + "Normal: d sets the span to one day and refreshes via the safe redo." + (let ((cj/--agenda-frame-span 7) redone) + (cl-letf (((symbol-function 'cj/--agenda-frame-safe-redo) + (lambda (&rest _) (setq redone t)))) + (cj/--agenda-frame-day-view) + (should (equal cj/--agenda-frame-span 1)) + (should redone)))) + +(ert-deftest test-org-agenda-frame-week-view-sets-span-7-and-redoes () + "Normal: w restores the seven-day span and refreshes." + (let ((cj/--agenda-frame-span 1) redone) + (cl-letf (((symbol-function 'cj/--agenda-frame-safe-redo) + (lambda (&rest _) (setq redone t)))) + (cj/--agenda-frame-week-view) + (should (equal cj/--agenda-frame-span 7)) + (should redone)))) + +(ert-deftest test-org-agenda-frame-command-tight-prefix-format () + "Normal: the view sets its own prefix format with a narrow category column. +Without it the global agenda format applies, whose 25-char category pad +leaves a wide blank gutter between the source name and the item." + (let ((s (test-org-agenda-frame--block-settings))) + (should (assq 'org-agenda-prefix-format s)) + (should (string-match-p "%-10:c" + (cadr (assq 'org-agenda-prefix-format s)))))) + +(ert-deftest test-org-agenda-frame-command-skips-done-items () + "Normal: completed tasks never appear in the Full Agenda. +The global agenda deliberately shows scheduled done items, so the dedicated +view needs its own skip function to exclude every done-state keyword." + (let* ((settings (test-org-agenda-frame--block-settings)) + (skip (assq 'org-agenda-skip-function settings))) + (should skip) + (should (equal (eval (cadr skip) t) + '(org-agenda-skip-entry-if 'todo 'done))))) + +(ert-deftest test-org-agenda-frame-command-render-excludes-scheduled-done () + "Boundary: a scheduled high-priority DONE item is absent from rendered output. +An equally scheduled active task remains, proving the whole date was not +skipped." + (require 'org-agenda) + (let* ((file (make-temp-file "agenda-frame-done-" nil ".org")) + (today (format-time-string "%Y-%m-%d %a")) + (org-agenda-files (list file)) + (org-agenda-custom-commands (list (cj/--agenda-frame-command))) + (org-agenda-sticky nil) + (agenda-buffer "*Org Agenda*")) + (unwind-protect + (progn + (with-temp-file file + (insert "#+TODO: TODO | DONE\n" + "* DONE [#A] completed-scheduled-marker\n" + "SCHEDULED: <" today ">\n" + "* TODO [#A] active-scheduled-marker\n" + "SCHEDULED: <" today ">\n")) + (org-agenda nil cj/--agenda-frame-command-key) + (with-current-buffer agenda-buffer + (should-not (string-match-p "completed-scheduled-marker" + (buffer-string))) + (should (string-match-p "active-scheduled-marker" + (buffer-string))))) + (when (get-buffer agenda-buffer) + (kill-buffer agenda-buffer)) + (delete-file file)))) + +(ert-deftest test-org-agenda-frame-do-redo-leaves-sticky-alone () + "Normal: the redo binds current-window but never touches sticky. +org-agenda-redo handles the in-place rebuild itself (it binds sticky nil +and redirects the buffer name); a sticky t reaching org-agenda-prepare +mid-redo makes it throw \\='exit with no catch and the tick fails." + (let ((org-agenda-sticky nil) + seen-sticky seen-setup (params '())) + (with-temp-buffer + (insert "agenda line\n") + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) + (setq seen-sticky org-agenda-sticky + seen-setup org-agenda-window-setup))) + ((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setf (alist-get p params) v)))) + (cj/--agenda-frame-do-redo 'af (current-buffer) nil) + (should (null seen-sticky)) + (should (eq seen-setup 'current-window)))))) + +(ert-deftest test-org-agenda-frame-command-follow-mode-off () + "Boundary: follow-mode is forced off locally so a global default can't split." + (let ((s (test-org-agenda-frame--block-settings))) + (should (assq 'org-agenda-start-with-follow-mode s)) + (should (null (cadr (assq 'org-agenda-start-with-follow-mode s)))))) + +(ert-deftest test-org-agenda-frame-command-sticky-and-current-window () + "Normal: current-window in the settings; sticky deliberately NOT there. +The general settings are baked into the buffer's series-redo-cmd and +re-applied on every redo; a sticky t there makes org-agenda-use-sticky-p +true mid-redo (the buffer exists), and org-agenda-prepare throws \\='exit +with no catch -- every refresh tick fails. Stickiness belongs only in +the spawn wrapper, where it names the buffer." + (let ((g (test-org-agenda-frame--general-settings))) + (should-not (assq 'org-agenda-sticky g)) + ;; org evaluates custom-command setting values via org-let, so the stored + ;; form is (quote current-window); eval it the way org would. + (should (eq (eval (cadr (assq 'org-agenda-window-setup g)) t) + 'current-window)))) + +;;; cj/--agenda-frame-register-command — idempotent registration + +(ert-deftest test-org-agenda-frame-register-adds-entry () + "Normal: registration inserts the F entry into org-agenda-custom-commands." + (let ((org-agenda-custom-commands '(("d" "Daily" nil)))) + (cj/--agenda-frame-register-command) + (should (assoc "F" org-agenda-custom-commands)) + (should (assoc "d" org-agenda-custom-commands)))) + +(ert-deftest test-org-agenda-frame-register-is-idempotent () + "Boundary: registering twice leaves exactly one F entry." + (let ((org-agenda-custom-commands nil)) + (cj/--agenda-frame-register-command) + (cj/--agenda-frame-register-command) + (should (= 1 (seq-count (lambda (e) (equal (car e) "F")) + org-agenda-custom-commands))))) + +;;; Default-deny policy — denial handlers + +(ert-deftest test-org-agenda-frame-denied-readonly-messages () + "Normal: the read-only denial shows the read-only message and acts on nothing." + (let (captured) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--agenda-frame-denied-readonly)) + (should (string-match-p "read-only" captured)) + (should (string-match-p "working frame" captured)))) + +(ert-deftest test-org-agenda-frame-denied-fixed-view-messages () + "Normal: the view-change denial shows the fixed-view message." + (let (captured) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--agenda-frame-denied-fixed-view)) + (should (string-match-p "day (d) and week (w)" captured)))) + +;;; Default-deny policy — the keymap + +(ert-deftest test-org-agenda-frame-map-catch-all-is-readonly-deny () + "Normal: the [t] default binding denies with the read-only handler." + (should (eq (lookup-key cj/agenda-frame-mode-map [t]) + 'cj/--agenda-frame-denied-readonly))) + +(ert-deftest test-org-agenda-frame-map-navigation-allowed () + "Normal: navigation keys resolve to their org-agenda commands." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "n")) 'org-agenda-next-line)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "p")) 'org-agenda-previous-line)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-g")) 'keyboard-quit))) + +(ert-deftest test-org-agenda-frame-map-point-motion-and-isearch-allowed () + "Normal: read-only point motion and isearch work in the frame. +C-a/C-e/C-f/C-b move point and C-s/C-r search; all are read-only and +must not hit the deny catch-all." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-a")) 'move-beginning-of-line)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-e")) 'move-end-of-line)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-f")) 'forward-char)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-b")) 'backward-char)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-s")) 'isearch-forward)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-r")) 'isearch-backward))) + +(ert-deftest test-org-agenda-frame-map-engage-routed () + "Normal: RET and TAB route to the working-frame engage command." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "RET")) + 'cj/--agenda-frame-engage-open)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "TAB")) + 'cj/--agenda-frame-engage-open))) + +(ert-deftest test-org-agenda-frame-map-engage-gui-function-keys () + "Boundary: the GUI [return]/[tab] events engage too, not the [t] deny handler. +Without these, the catch-all suppresses their translation to RET/TAB in a +graphical frame and RET would be denied instead of opening the item." + (should (eq (lookup-key cj/agenda-frame-mode-map [return]) + 'cj/--agenda-frame-engage-open)) + (should (eq (lookup-key cj/agenda-frame-mode-map [tab]) + 'cj/--agenda-frame-engage-open))) + +(ert-deftest test-org-agenda-frame-map-lifecycle-keys () + "Normal: q/Q/x close the frame; r and g take the safe-redo path. +g is the muscle-memory agenda refresh; it must refresh, not hit the +fixed-view deny handler." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "q")) 'cj/--agenda-frame-close)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "Q")) 'cj/--agenda-frame-close)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "x")) 'cj/--agenda-frame-close)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "r")) 'cj/--agenda-frame-safe-redo)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "g")) 'cj/--agenda-frame-safe-redo))) + +(ert-deftest test-org-agenda-frame-map-view-changers-fixed-view-deny () + "Boundary: view-changing keys are explicitly denied with the fixed-view message, +not caught by the read-only catch-all." + (dolist (key '("y" "f" "b" "j")) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd key)) + 'cj/--agenda-frame-denied-fixed-view)))) + +(ert-deftest test-org-agenda-frame-map-day-week-view-keys () + "Normal: d and w toggle the span (day / week) rather than being denied. +d shrinks the frame to the current day, w restores the seven-day span." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "d")) + 'cj/--agenda-frame-day-view)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "w")) + 'cj/--agenda-frame-week-view))) + +(ert-deftest test-org-agenda-frame-map-controlled-task-mutations () + "Normal: status and priority changes are the frame's controlled mutations. +C-c t is Craig's requested status chord, C-c C-t keeps Org's standard agenda +chord, and both Meta and the configured Super arrows support the same +priority/status operations." + (dolist (binding '(("C-c t" . org-agenda-todo) + ("C-c C-t" . org-agenda-todo) + ("M-<up>" . org-agenda-priority-up) + ("M-<down>" . org-agenda-priority-down) + ("M-<left>" . org-agenda-todo-previousset) + ("M-<right>" . org-agenda-todo-nextset) + ("s-<up>" . org-agenda-priority-up) + ("s-<down>" . org-agenda-priority-down) + ("s-<left>" . org-agenda-todo-previousset) + ("s-<right>" . org-agenda-todo-nextset))) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd (car binding))) + (cdr binding))))) + +(ert-deftest test-org-agenda-frame-shadow-denies-org-mutations-preserves-allowlist () + "Boundary: with the frame mode active over `org-agenda-mode-map', mutating +org-agenda keys are denied and the allowlist still works. +The `[t]' default cannot shadow org-agenda-mode-map's explicit bindings, so +the shadow walk must add explicit denies for every non-allowlisted key -- +single keys (t/I/k/z/s/.), the C-c mutators (schedule/deadline/clock), and +C-x (save-all) -- while leaving the allowlist (navigation, engage, refresh, +d/w, C-c C-o) intact." + (require 'org-agenda) + (cj/--agenda-frame-shadow-mutations) + (with-temp-buffer + (use-local-map org-agenda-mode-map) + (cj/agenda-frame-mode 1) + ;; escaping mutators are now explicitly denied (not org's commands) + (dolist (chord '("t" "I" "k" "z" "s" "." "C-c C-s" "C-c C-d" + "C-c C-x C-i" "C-x C-s")) + (should (eq (key-binding (kbd chord)) + 'cj/--agenda-frame-denied-readonly))) + ;; the allowlist survives the walk + (should (eq (key-binding (kbd "n")) 'org-agenda-next-line)) + (should (eq (key-binding (kbd "p")) 'org-agenda-previous-line)) + (should (eq (key-binding (kbd "RET")) 'cj/--agenda-frame-engage-open)) + (should (eq (key-binding (kbd "g")) 'cj/--agenda-frame-safe-redo)) + (should (eq (key-binding (kbd "d")) 'cj/--agenda-frame-day-view)) + (should (eq (key-binding (kbd "w")) 'cj/--agenda-frame-week-view)) + (should (eq (key-binding (kbd "C-c t")) 'org-agenda-todo)) + (should (eq (key-binding (kbd "C-c C-t")) 'org-agenda-todo)) + (should (eq (key-binding (kbd "M-<up>")) 'org-agenda-priority-up)) + (should (eq (key-binding (kbd "M-<right>")) 'org-agenda-todo-nextset)) + (should (eq (key-binding (kbd "s-<down>")) 'org-agenda-priority-down)) + (should (eq (key-binding (kbd "s-<left>")) 'org-agenda-todo-previousset)) + (should (eq (key-binding (kbd "C-c C-o")) 'cj/--agenda-frame-open-link)) + (should (eq (key-binding (kbd "q")) 'cj/--agenda-frame-close)))) + +(ert-deftest test-org-agenda-frame-map-frame-controls-bound () + "Normal: the frame's own controls work from inside the frame. +S-<f8> must close/toggle and C-M-<f8> must force-rescan; unbound, the +catch-all denies them and the frame can't be closed by its own key." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "S-<f8>")) + 'cj/agenda-frame-toggle)) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-M-<f8>")) + 'cj/org-agenda-refresh-files))) + +(ert-deftest test-org-agenda-frame-map-C-x-C-c-closes-frame () + "Normal: C-x C-c in the agenda frame closes the frame, not the daemon. +The global save-buffers-kill-terminal would kill Emacs itself here (a +make-frame frame has no client), so the intuitive close gesture must be +remapped to the frame close." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-x C-c")) + 'cj/--agenda-frame-close))) + +(ert-deftest test-org-agenda-frame-map-machinery-punched-through () + "Boundary: input machinery is punched through the [t] catch-all. +switch-frame events, mouse-wheel scrolling, mouse-1 clicks, and the help +prefix must fall through to their global bindings (an explicit nil shadows +the default in this map); otherwise every frame-focus change and every +scroll spams the deny message." + (dolist (key (list [switch-frame] + [wheel-up] [wheel-down] [wheel-left] [wheel-right] + [double-wheel-up] [double-wheel-down] + [triple-wheel-up] [triple-wheel-down] + [mouse-1] [down-mouse-1] [drag-mouse-1] + (kbd "C-h"))) + ;; accept-default t: a punched key returns nil (falls through to the + ;; global map); an unpunched key returns the catch-all deny handler. + (should (null (lookup-key cj/agenda-frame-mode-map key t))))) + +(ert-deftest test-org-agenda-frame-map-global-escape-chords-denied () + "Boundary: global chords bound elsewhere (M-SPC / M-S-SPC swap ai-term +agents) are denied by an explicit binding, not left to the [t] catch-all. +A keymap's default binding does not shadow an explicit binding in a +lower-priority map, so without an explicit deny here M-SPC follows its +global binding and escapes the read-only frame into ai-term." + (dolist (key '("M-SPC" "M-S-SPC")) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd key)) + 'cj/--agenda-frame-denied-readonly)))) + +(ert-deftest test-org-agenda-frame-map-unpunched-still-denied () + "Normal: an ordinary unbound key still hits the catch-all after the punches." + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "t") t) + 'cj/--agenda-frame-denied-readonly))) + +(ert-deftest test-org-agenda-frame-maybe-enable-readds-kill-buffer-hook () + "Normal: the finalize re-enable also re-adds the buffer-local kill hook. +org-agenda-redo's kill-all-local-variables strips the hook installed at +spawn; without the re-add, killing the buffer after the first refresh tick +orphans the frame." + (with-temp-buffer + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'agenda)) + ((symbol-function 'get-buffer-window) (lambda (_b _f) 'win))) + (cj/--agenda-frame-maybe-enable-mode) + (should (memq 'cj/--agenda-frame-on-kill-buffer + (buffer-local-value 'kill-buffer-hook (current-buffer))))))) + +(ert-deftest test-org-agenda-frame-overlay-removable-after-local-var-wipe () + "Error: the failure overlay is found by property, not a buffer-local var. +kill-all-local-variables (every redo) wipes buffer-local vars while the +overlay object survives erase-buffer, so a var-held overlay could never be +removed after a later success -- the failure banner would stick forever." + (with-temp-buffer + (insert "x\n") + (cj/--agenda-frame-show-failure-overlay (current-buffer)) + ;; Simulate the org-agenda-mode reset between failure and success. + (kill-all-local-variables) + (cj/--agenda-frame-remove-overlay (current-buffer)) + ;; The visible banner (a before-string overlay) must be gone. + (should (= 0 (seq-count (lambda (o) (overlay-get o 'before-string)) + (overlays-in (point-min) (point-max))))))) + +(ert-deftest test-org-agenda-frame-map-mutation-keys-denied () + "Boundary: a mutation key (t = org-agenda-todo) is denied, never allowlisted. +It is denied two ways depending on whether the shadow walk has run: the `[t]' +catch-all handles it (lookup returns nil) before the walk, and the walk binds +it explicitly to the deny handler once `org-agenda-mode-map' is present. Both +are a read-only denial; the test asserts the outcome, not which path produced +it, so it holds whether or not org-agenda is loaded in the test process." + (let ((b (lookup-key cj/agenda-frame-mode-map (kbd "t")))) + (should (or (null b) (eq b 'cj/--agenda-frame-denied-readonly))))) + +;;; Default-deny policy — the minor mode + finalize re-enable + +(ert-deftest test-org-agenda-frame-mode-toggles () + "Normal: the minor mode turns on and off in a buffer." + (with-temp-buffer + (cj/agenda-frame-mode 1) + (should cj/agenda-frame-mode) + (cj/agenda-frame-mode -1) + (should-not cj/agenda-frame-mode))) + +(ert-deftest test-org-agenda-frame-maybe-enable-in-agenda-frame () + "Normal: after a build in the agenda frame, the policy is re-enabled." + (with-temp-buffer + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'agenda)) + ((symbol-function 'get-buffer-window) (lambda (_b _f) 'win))) + (cj/--agenda-frame-maybe-enable-mode) + (should cj/agenda-frame-mode)))) + +(ert-deftest test-org-agenda-frame-maybe-enable-skips-other-buffers () + "Boundary: a build not shown in the agenda frame leaves the policy off." + (with-temp-buffer + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'agenda)) + ((symbol-function 'get-buffer-window) (lambda (_b _f) nil))) + (cj/--agenda-frame-maybe-enable-mode) + (should-not cj/agenda-frame-mode)))) + +(ert-deftest test-org-agenda-frame-maybe-enable-no-frame () + "Boundary: no agenda frame at all -> policy stays off, no error." + (with-temp-buffer + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil))) + (cj/--agenda-frame-maybe-enable-mode) + (should-not cj/agenda-frame-mode)))) + +;;; Engage routing — frame target + open + +(ert-deftest test-org-agenda-frame-target-frame-uses-working-frame () + "Normal: the engage target is the working frame when one exists." + (cl-letf (((symbol-function 'cj/--agenda-frame-working-frame) (lambda () 'work)) + ((symbol-function 'make-frame) (lambda (&rest _) (error "should not create")))) + (should (eq (cj/--agenda-frame-target-frame) 'work)))) + +(ert-deftest test-org-agenda-frame-target-frame-creates-when-none () + "Boundary: no working frame -> a normal frame is created." + (cl-letf (((symbol-function 'cj/--agenda-frame-working-frame) (lambda () nil)) + ((symbol-function 'make-frame) (lambda (&rest _) 'new))) + (should (eq (cj/--agenda-frame-target-frame) 'new)))) + +(ert-deftest test-org-agenda-frame-engage-open-no-item-errors () + "Error: engaging on a line with no source item signals a user-error." + (cl-letf (((symbol-function 'cj/--agenda-frame-item-marker) (lambda () nil))) + (should-error (cj/--agenda-frame-engage-open) :type 'user-error))) + +(ert-deftest test-org-agenda-frame-engage-open-routes-to-source () + "Normal: engage opens the item's source buffer at the item's position." + (let ((source (generate-new-buffer " *frame-engage-source*"))) + (unwind-protect + (progn + (with-current-buffer source (insert "line one\nline two\nline three\n")) + (let ((marker (set-marker (make-marker) 10 source)) + focused opened) + (cl-letf (((symbol-function 'cj/--agenda-frame-item-marker) (lambda () marker)) + ((symbol-function 'cj/--agenda-frame-target-frame) (lambda () 'work)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f))) + ((symbol-function 'pop-to-buffer-same-window) + (lambda (b &rest _) (setq opened b) (set-buffer b))) + ((symbol-function 'org-fold-show-context) (lambda (&rest _) nil))) + (cj/--agenda-frame-engage-open) + (should (eq focused 'work)) + (should (eq opened source)) + (should (eq (current-buffer) source)) + (should (= (point) (line-beginning-position)))))) + (kill-buffer source)))) + +;;; Frame lifecycle — sticky buffer, timer-cancel, teardown cleanup + +(ert-deftest test-org-agenda-frame-sticky-buffer-name () + "Normal: the sticky buffer is *Org Agenda(F)*; nil when absent." + (should (null (cj/--agenda-frame-sticky-buffer))) + (let ((buf (get-buffer-create "*Org Agenda(F)*"))) + (unwind-protect + (should (eq (cj/--agenda-frame-sticky-buffer) buf)) + (kill-buffer buf)))) + +(ert-deftest test-org-agenda-frame-cancel-timer-safe-when-none () + "Boundary: cancelling with no timer set does nothing and does not error." + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil))) + (should-not (cj/--agenda-frame-cancel-timer)))) + +;;; Frame lifecycle — toggle dispatch + +(ert-deftest test-org-agenda-frame-toggle-spawns-when-none () + "Normal: with no agenda frame, toggle spawns one." + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil)) + ((symbol-function 'cj/--agenda-frame-spawn) (lambda () 'spawned))) + (should (eq (cj/--agenda-frame-toggle) 'spawned)))) + +(ert-deftest test-org-agenda-frame-toggle-deletes-when-selected () + "Normal: toggle from within the agenda frame deletes it." + (let (deleted) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'selected-frame) (lambda () 'af)) + ((symbol-function 'cj/--agenda-frame-delete) + (lambda () (setq deleted t)))) + (cj/--agenda-frame-toggle) + (should deleted)))) + +(ert-deftest test-org-agenda-frame-toggle-raises-when-unfocused () + "Normal: toggle from a working frame raises the existing agenda frame." + (let (raised) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'selected-frame) (lambda () 'work)) + ((symbol-function 'cj/--agenda-frame-raise) + (lambda (f) (setq raised f)))) + (cj/--agenda-frame-toggle) + (should (eq raised 'af))))) + +;;; Frame lifecycle — delete + +(ert-deftest test-org-agenda-frame-delete-deletes-live-frame () + "Normal: delete removes the live agenda frame." + (let (deleted) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'frame-live-p) (lambda (f) (eq f 'af))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--agenda-frame-delete) + (should (eq deleted 'af))))) + +(ert-deftest test-org-agenda-frame-delete-noop-when-none () + "Boundary: delete with no agenda frame does nothing." + (let (called) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil)) + ((symbol-function 'delete-frame) (lambda (_f &rest _) (setq called t)))) + (cj/--agenda-frame-delete) + (should-not called)))) + +;;; Frame lifecycle — cleanup on frame death and buffer kill + +(ert-deftest test-org-agenda-frame-on-delete-cancels-and-kills-buffer () + "Normal: deleting the agenda frame cancels its timer and kills the sticky buffer." + (let ((buf (get-buffer-create "*Org Agenda(F)*")) + cancelled) + (unwind-protect + (cl-letf (((symbol-function 'cj/--agenda-frame-p) (lambda (_f) t)) + ((symbol-function 'cj/--agenda-frame-cancel-timer) + (lambda (&optional _f) (setq cancelled t)))) + (cj/--agenda-frame-on-delete-frame 'af) + (should cancelled) + (should-not (buffer-live-p buf))) + (when (buffer-live-p buf) (kill-buffer buf))))) + +(ert-deftest test-org-agenda-frame-on-delete-ignores-non-agenda-frame () + "Boundary: a non-agenda frame deletion triggers no cleanup." + (let (cancelled) + (cl-letf (((symbol-function 'cj/--agenda-frame-p) (lambda (_f) nil)) + ((symbol-function 'cj/--agenda-frame-cancel-timer) + (lambda (&optional _f) (setq cancelled t)))) + (cj/--agenda-frame-on-delete-frame 'work) + (should-not cancelled)))) + +(ert-deftest test-org-agenda-frame-on-kill-buffer-deletes-frame () + "Normal: killing the dedicated buffer deletes the frame." + (let (deleted) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'frame-live-p) (lambda (f) (eq f 'af))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--agenda-frame-on-kill-buffer) + (should (eq deleted 'af))))) + +(ert-deftest test-org-agenda-frame-on-kill-buffer-guarded-during-teardown () + "Boundary: during a teardown the buffer-kill hook does not re-delete the frame." + (let (deleted (cj/--agenda-frame-tearing-down t)) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--agenda-frame-on-kill-buffer) + (should-not deleted)))) + +;;; Auto-dim suspension while the agenda frame lives + +(ert-deftest test-org-agenda-frame-spawn-suspends-auto-dim () + "Normal: spawning the frame turns auto-dim off and remembers it was on. +The refresh tick's selection swing marks the working window non-selected; +auto-dim's debounced dim then lands after the tick and the working frame +visibly dims every five minutes." + (defvar auto-dim-other-buffers-mode) + (let ((auto-dim-other-buffers-mode t) + (cj/--agenda-frame-dim-was-on nil) + calls) + (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) + (lambda (arg) (push arg calls))) + ((symbol-function 'selected-frame) (lambda () 'launch)) + ((symbol-function 'make-frame) (lambda (&rest _) 'af)) + ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) + ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) + ((symbol-function 'org-agenda) (lambda (&rest _) nil)) + ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) + ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) + (cj/--agenda-frame-spawn) + (should (equal calls '(-1))) + (should cj/--agenda-frame-dim-was-on)))) + +(ert-deftest test-org-agenda-frame-spawn-leaves-auto-dim-when-off () + "Boundary: auto-dim already off -> spawn doesn't touch it, no restore later." + (defvar auto-dim-other-buffers-mode) + (let ((auto-dim-other-buffers-mode nil) + (cj/--agenda-frame-dim-was-on nil) + calls) + (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) + (lambda (arg) (push arg calls))) + ((symbol-function 'selected-frame) (lambda () 'launch)) + ((symbol-function 'make-frame) (lambda (&rest _) 'af)) + ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) + ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) + ((symbol-function 'org-agenda) (lambda (&rest _) nil)) + ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) + ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) + (cj/--agenda-frame-spawn) + (should (null calls)) + (should-not cj/--agenda-frame-dim-was-on)))) + +(ert-deftest test-org-agenda-frame-on-delete-restores-auto-dim () + "Normal: closing the frame restores auto-dim when spawn had turned it off." + (let ((cj/--agenda-frame-dim-was-on t) + calls) + (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) + (lambda (arg) (push arg calls))) + ((symbol-function 'cj/--agenda-frame-p) (lambda (_f) t)) + ((symbol-function 'cj/--agenda-frame-cancel-timer) + (lambda (&optional _f) nil))) + (cj/--agenda-frame-on-delete-frame 'af) + (should (equal calls '(1))) + (should-not cj/--agenda-frame-dim-was-on)))) + +(ert-deftest test-org-agenda-frame-on-delete-no-dim-restore-when-untouched () + "Boundary: closing without a suspended auto-dim doesn't enable it." + (let ((cj/--agenda-frame-dim-was-on nil) + calls) + (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) + (lambda (arg) (push arg calls))) + ((symbol-function 'cj/--agenda-frame-p) (lambda (_f) t)) + ((symbol-function 'cj/--agenda-frame-cancel-timer) + (lambda (&optional _f) nil))) + (cj/--agenda-frame-on-delete-frame 'af) + (should (null calls))))) + +;;; Frame lifecycle — transactional spawn rollback + +(ert-deftest test-org-agenda-frame-spawn-rolls-back-on-failure () + "Error: a failure after make-frame deletes the partial frame, restores the +working frame, and signals a user-error." + (let (deleted focus) + (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) + ((symbol-function 'make-frame) (lambda (&rest _) 'pf)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focus f))) + ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) + ((symbol-function 'org-agenda) (lambda (&rest _) (error "boom"))) + ((symbol-function 'frame-live-p) (lambda (f) (memq f '(pf launch)))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (should-error (cj/--agenda-frame-spawn) :type 'user-error) + (should (eq deleted 'pf)) + (should (eq focus 'launch))))) + +;;; Phase 2 — wall-clock alignment + +(ert-deftest test-org-agenda-frame-seconds-to-next-mark-aligned () + "Normal: a time exactly on a 5-minute boundary yields a full period." + ;; 1000000200 is divisible by 300 (a :00/:05 wall-clock mark). + (should (= (cj/--agenda-frame-seconds-to-next-mark 1000000200 300) 300))) + +(ert-deftest test-org-agenda-frame-seconds-to-next-mark-midway () + "Boundary: partway through a period returns the remainder to the next mark." + ;; 1000000200 + 120 -> 180 seconds remain to the next 300 mark. + (should (= (cj/--agenda-frame-seconds-to-next-mark 1000000320 300) 180))) + +;;; Phase 2 — deterministic point restoration + +(defun test-org-agenda-frame--make-agenda-buffer (lines source) + "Insert LINES into the current buffer; each is (TEXT . SRC-POS). +A non-nil SRC-POS puts an org-marker into SOURCE at that position on the line." + (dolist (spec lines) + (let ((start (point))) + (insert (car spec) "\n") + (when (cdr spec) + (put-text-property start (1+ start) 'org-marker + (set-marker (make-marker) (cdr spec) source)))))) + +(ert-deftest test-org-agenda-frame-restore-point-duplicate-nearest () + "Normal: a source marker occurring twice restores the occurrence nearest the old line." + (let ((src (generate-new-buffer " *rp-src*"))) + (unwind-protect + (with-temp-buffer + (with-current-buffer src (insert "aaaaaaaaaa\n")) + (test-org-agenda-frame--make-agenda-buffer + '(("header" . nil) ("item @2" . 3) ("filler" . nil) + ("filler" . nil) ("item @5" . 3)) + src) + (let ((old (set-marker (make-marker) 3 src))) + (cj/--agenda-frame-restore-point old 4)) + ;; lines 2 and 5 both point at src pos 3; nearest to old-line 4 is line 5. + (should (= (line-number-at-pos) 5))) + (kill-buffer src)))) + +(ert-deftest test-org-agenda-frame-restore-point-missing-clamps () + "Boundary: a gone marker clamps the old line into range and lands on an item." + (let ((src (generate-new-buffer " *rp-src*"))) + (unwind-protect + (with-temp-buffer + (with-current-buffer src (insert "aaaaaaaaaa\n")) + (test-org-agenda-frame--make-agenda-buffer + '(("header" . nil) ("item" . 3) ("item" . 5)) + src) + ;; old-line 99 is past the end; clamp to last line (an item). + (let ((gone (set-marker (make-marker) 99 src))) + (cj/--agenda-frame-restore-point gone 99)) + (should (get-text-property (line-beginning-position) 'org-marker))) + (kill-buffer src)))) + +(ert-deftest test-org-agenda-frame-restore-point-header-goes-to-first-item () + "Boundary: with no marker match, a header line moves to the first item." + (let ((src (generate-new-buffer " *rp-src*"))) + (unwind-protect + (with-temp-buffer + (with-current-buffer src (insert "aaaaaaaaaa\n")) + (test-org-agenda-frame--make-agenda-buffer + '(("header" . nil) ("item one" . 3) ("item two" . 5)) + src) + (cj/--agenda-frame-restore-point nil 1) ; line 1 is the header + (should (= (line-number-at-pos) 2)) + (should (get-text-property (line-beginning-position) 'org-marker))) + (kill-buffer src)))) + +(ert-deftest test-org-agenda-frame-restore-point-empty-buffer-start () + "Error: an empty (item-less) view leaves point at buffer start." + (with-temp-buffer + (test-org-agenda-frame--make-agenda-buffer + '(("only a header" . nil) ("no items here" . nil)) nil) + (cj/--agenda-frame-restore-point nil 2) + (should (= (point) (point-min))))) + +;;; Phase 2 — snapshot marker cloning + +(ert-deftest test-org-agenda-frame-clone-and-reinstall-markers () + "Normal: cloned markers survive nulling the originals and reinstall live." + (let ((src (generate-new-buffer " *clone-src*"))) + (unwind-protect + (let (clones) + (with-temp-buffer + (with-current-buffer src (insert "0123456789\n")) + (test-org-agenda-frame--make-agenda-buffer '(("item" . 4)) src) + (setq clones (cj/--agenda-frame-snapshot-markers (current-buffer))) + ;; Simulate org-agenda-reset-markers nulling the buffer's originals. + (let ((orig (get-text-property (point-min) 'org-marker))) + (set-marker orig nil))) + ;; Reinstall into a fresh buffer copy; the clone must still be live. + (with-temp-buffer + (test-org-agenda-frame--make-agenda-buffer '(("item" . nil)) nil) + (cj/--agenda-frame-reinstall-markers (current-buffer) clones) + (let ((m (get-text-property (point-min) 'org-marker))) + (should (markerp m)) + (should (eq (marker-buffer m) src)) + (should (= (marker-position m) 4))))) + (kill-buffer src)))) + +;;; Phase 2 — failure latch (report once per consecutive-failure run) + +(ert-deftest test-org-agenda-frame-failure-latch-reports-once () + "Normal: the first failure of a run reports; subsequent ones stay silent." + (let ((params '())) + (cl-letf (((symbol-function 'frame-parameter) + (lambda (_f p) (alist-get p params))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setf (alist-get p params) v)))) + (should (cj/--agenda-frame-record-failure 'af)) ; 0 -> 1, report + (should-not (cj/--agenda-frame-record-failure 'af)) ; 1 -> 2, silent + (cj/--agenda-frame-clear-failure 'af) + (should (cj/--agenda-frame-record-failure 'af))))) ; reset -> report again + +;;; Phase 2 — timer start + duplicate prevention + +(ert-deftest test-org-agenda-frame-start-timer-sets-timer () + "Normal: start-timer schedules and stores a timer when none exists." + (let (stored) + (cl-letf (((symbol-function 'frame-parameter) (lambda (_f _p) nil)) + ((symbol-function 'run-at-time) (lambda (&rest _) 'the-timer)) + ((symbol-function 'set-frame-parameter) + (lambda (_f _p v) (setq stored v)))) + (should (eq (cj/--agenda-frame-start-timer 'af) 'the-timer)) + (should (eq stored 'the-timer))))) + +(ert-deftest test-org-agenda-frame-start-timer-no-duplicate () + "Boundary: a frame already carrying a live timer is not given a second one." + (let (called) + (cl-letf (((symbol-function 'frame-parameter) (lambda (_f _p) 'existing)) + ((symbol-function 'timerp) (lambda (x) (eq x 'existing))) + ((symbol-function 'run-at-time) (lambda (&rest _) (setq called t) 'new))) + (cj/--agenda-frame-start-timer 'af) + (should-not called)))) + +;;; Phase 2 — do-redo orchestration (success and failure branches) + +(ert-deftest test-org-agenda-frame-do-redo-success-clears-and-releases () + "Normal: a successful redo clears the failure latch and releases the snapshot." + (let ((params (list (cons 'cj/agenda-frame-fail-count 3))) + released) + (with-temp-buffer + (insert "agenda line\n") + (cl-letf (((symbol-function 'org-agenda-redo) (lambda (&rest _) nil)) + ((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setf (alist-get p params) v))) + ((symbol-function 'cj/--agenda-frame-release-snapshot) + (lambda (_s) (setq released t)))) + (cj/--agenda-frame-do-redo 'af (current-buffer) nil) + (should (equal (alist-get 'cj/agenda-frame-fail-count params) 0)) + (should released))))) + +(ert-deftest test-org-agenda-frame-do-redo-error-restores-reenables-reports () + "Error: a redo that fails mid-rebuild restores the last-good buffer verbatim, +re-enables the policy, shows one overlay, and reports once." + (let ((params '()) msgs) + (with-temp-buffer + (insert "good agenda content\n") + (unwind-protect + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) (erase-buffer) (insert "PARTIAL") (error "boom"))) + ((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setf (alist-get p params) v))) + ((symbol-function 'message) + (lambda (fmt &rest a) (push (apply #'format fmt a) msgs)))) + (cj/--agenda-frame-do-redo 'af (current-buffer) nil) + (should cj/agenda-frame-mode) ; policy re-enabled + (should (= 1 (length (cj/--agenda-frame-failure-overlays + (current-buffer))))) ; overlay shown + (should (string-match-p "good agenda content" (buffer-string))) ; restored + (should-not (string-match-p "PARTIAL" (buffer-string))) + (should (= 1 (seq-count (lambda (m) (string-match-p "refresh failed" m)) + msgs)))) + (cj/agenda-frame-mode -1) + (cj/--agenda-frame-remove-overlay (current-buffer)))))) + +(ert-deftest test-org-agenda-frame-do-redo-follows-item-across-shift () + "Normal: on a successful redo, point follows the same source item even when +lines shift and the buffer's own markers are nulled (the reset-markers case). +Guards against restoring by raw line number after the item moved." + (let ((src (generate-new-buffer " *shift-src*")) + (params '())) + (unwind-protect + (with-temp-buffer + (with-current-buffer src (insert "0123456789\n")) + ;; Before: item B (src pos 5) sits on line 3, and point is on it. + (test-org-agenda-frame--make-agenda-buffer + '(("header" . nil) ("item A" . 3) ("item B" . 5)) src) + (goto-char (point-min)) (forward-line 2) ; line 3, item B + (cl-letf (((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setf (alist-get p params) v))) + ((symbol-function 'org-agenda-redo) + (lambda (&rest _) + ;; Null the buffer's originals (as org-agenda-reset-markers + ;; does), then rebuild with item B shifted to line 4. + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (let ((m (get-text-property (line-beginning-position) 'org-marker))) + (when (markerp m) (set-marker m nil))) + (forward-line 1))) + (erase-buffer) + (test-org-agenda-frame--make-agenda-buffer + '(("header" . nil) ("new item" . 1) ("item A" . 3) ("item B" . 5)) + src)))) + (cj/--agenda-frame-do-redo 'af (current-buffer) nil)) + ;; Point should be on the rebuilt item B (src pos 5), now line 4 -- + ;; not clamped to old line 3 (which is now item A, src pos 3). + (let ((m (get-text-property (line-beginning-position) 'org-marker))) + (should (markerp m)) + (should (= (marker-position m) 5)))) + (kill-buffer src)))) + +;;; Phase 2 — snapshot round-trip, release, safe-redo window contract, overlay + +(ert-deftest test-org-agenda-frame-restore-snapshot-round-trip () + "Normal: snapshot then restore reinstates text and a live cloned marker." + (let ((src (generate-new-buffer " *ss-src*"))) + (unwind-protect + (with-temp-buffer + (with-current-buffer src (insert "0123456789\n")) + (test-org-agenda-frame--make-agenda-buffer '(("item alpha" . 4)) src) + (let ((snap (cj/--agenda-frame-snapshot (current-buffer) nil))) + (erase-buffer) + (insert "CORRUPT") + (cj/--agenda-frame-restore-snapshot (current-buffer) snap nil) + (should (string-match-p "item alpha" (buffer-string))) + (let ((m (get-text-property (point-min) 'org-marker))) + (should (markerp m)) + (should (eq (marker-buffer m) src)) + (should (= (marker-position m) 4))) + (cj/--agenda-frame-release-snapshot snap) + (should-not (marker-buffer (cdr (car (plist-get snap :markers))))))) + (kill-buffer src)))) + +(ert-deftest test-org-agenda-frame-safe-redo-selects-and-restores-window () + "Normal: the active tick runs the redo and restores the prior window (no focus theft)." + (let (redone (prev (selected-window))) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) + (lambda () (current-buffer))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'get-buffer-window) (lambda (&rest _) prev)) + ((symbol-function 'cj/--agenda-frame-do-redo) + (lambda (&rest _) (setq redone t)))) + (cj/--agenda-frame-safe-redo) + (should redone) + (should (eq (selected-window) prev))))) + +(ert-deftest test-org-agenda-frame-overlay-idempotent () + "Boundary: showing the failure overlay twice keeps a single overlay." + (with-temp-buffer + (insert "x\n") + (unwind-protect + (progn + (cj/--agenda-frame-show-failure-overlay (current-buffer)) + (let ((first (car (cj/--agenda-frame-failure-overlays (current-buffer))))) + (cj/--agenda-frame-show-failure-overlay (current-buffer)) + (should (equal (cj/--agenda-frame-failure-overlays (current-buffer)) + (list first))) + (should (= 1 (seq-count (lambda (o) (overlay-get o 'before-string)) + (overlays-in (point-min) (point-max))))))) + (cj/--agenda-frame-remove-overlay (current-buffer))))) + +;;; Phase 2 — public command + F8-family rebind + +(ert-deftest test-org-agenda-frame-public-toggle-wraps-private () + "Normal: the interactive command delegates to the private toggle." + (let (called) + (cl-letf (((symbol-function 'cj/--agenda-frame-toggle) + (lambda () (setq called t)))) + (call-interactively 'cj/agenda-frame-toggle) + (should called)))) + +(ert-deftest test-org-agenda-frame-parameters-normal-tiled-frame () + "Boundary: the agenda frame is a normal frame (the tiling WM places it +side by side with the working frame), carrying the marker and a distinct name." + (let ((params (cj/--agenda-frame-make-parameters))) + (should (assq cj/--agenda-frame-parameter params)) + (should (equal (cdr (assq 'name params)) "Full Agenda")) + ;; No fullscreen request -- a fullboth frame would cover the whole output + ;; instead of tiling beside the working frame. + (should-not (assq 'fullscreen params)))) + +(ert-deftest test-org-agenda-frame-spawn-binds-sticky-and-current-window () + "Normal: spawn dynamically binds sticky + current-window around the render. +The custom command's own settings apply too late to name the buffer, so +without these bindings the buffer is plain *Org Agenda* -- which matches +the 0.75 below-selected display rule and splits the new frame with the +working buffer left on top." + (let (seen-sticky seen-setup) + (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) + ((symbol-function 'make-frame) (lambda (&rest _) 'af)) + ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) + ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) + ((symbol-function 'org-agenda) + (lambda (&rest _) + (setq seen-sticky org-agenda-sticky + seen-setup org-agenda-window-setup))) + ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) + ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) + (cj/--agenda-frame-spawn) + (should (eq seen-sticky t)) + (should (eq seen-setup 'current-window))))) + +(ert-deftest test-org-agenda-frame-spawn-forces-single-window () + "Boundary: spawn collapses the frame to one window after rendering. +A display rule that still splits the frame must not leave a second window +showing the launch buffer." + (let (collapsed) + (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) + ((symbol-function 'make-frame) (lambda (&rest _) 'af)) + ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) + ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) + ((symbol-function 'org-agenda) (lambda (&rest _) nil)) + ((symbol-function 'delete-other-windows) + (lambda (&rest _) (setq collapsed t))) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) + ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) + (cj/--agenda-frame-spawn) + (should collapsed)))) + +(ert-deftest test-org-agenda-frame-spawn-resets-span-to-7 () + "Normal: a fresh spawn opens at the documented seven-day default, even when a +prior frame's session left `cj/--agenda-frame-span' at the day view." + (let ((cj/--agenda-frame-span 1)) + (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) + ((symbol-function 'make-frame) (lambda (&rest _) 'af)) + ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) + ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) + ((symbol-function 'org-agenda) (lambda (&rest _) nil)) + ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) + ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) + (cj/--agenda-frame-spawn) + (should (equal cj/--agenda-frame-span 7))))) + +(ert-deftest test-org-agenda-frame-spawn-starts-timer () + "Normal: a successful spawn starts the refresh timer for the new frame." + (let (timed) + (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) + ((symbol-function 'make-frame) (lambda (&rest _) 'af)) + ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) + ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) + ((symbol-function 'org-agenda) (lambda (&rest _) nil)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) + ((symbol-function 'cj/--agenda-frame-start-timer) + (lambda (f) (setq timed f)))) + (should (eq (cj/--agenda-frame-spawn) 'af)) + (should (eq timed 'af))))) + +(ert-deftest test-org-agenda-frame-safe-redo-inhibits-redisplay () + "Normal: the tick runs with redisplay inhibited. +The rebuild takes visible time; without this, the agenda window is the +selected window for the whole rebuild and the user watches their cursor +go hollow every five minutes -- indistinguishable from focus theft." + (let (seen (prev (selected-window))) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) + (lambda () (current-buffer))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'get-buffer-window) (lambda (&rest _) prev)) + ((symbol-function 'cj/--agenda-frame-do-redo) + (lambda (&rest _) (setq seen inhibit-redisplay)))) + (cj/--agenda-frame-safe-redo) + (should (eq seen t))))) + +(ert-deftest test-org-agenda-frame-safe-redo-skips-during-minibuffer () + "Boundary: a tick while a minibuffer is active is skipped entirely. +Reselecting windows under an active minibuffer session can break it; the +next tick catches up." + (let (redone (prev (selected-window))) + (cl-letf (((symbol-function 'active-minibuffer-window) (lambda () 'mini)) + ((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) + (lambda () (current-buffer))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'get-buffer-window) (lambda (&rest _) prev)) + ((symbol-function 'cj/--agenda-frame-do-redo) + (lambda (&rest _) (setq redone t)))) + (cj/--agenda-frame-safe-redo) + (should-not redone)))) + +(ert-deftest test-org-agenda-frame-safe-redo-noop-when-not-shown () + "Boundary: a tick with the buffer not shown in the frame does not redo or error." + (let (redone) + (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) + ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) + ((symbol-function 'get-buffer-window) (lambda (&rest _) nil)) + ((symbol-function 'cj/--agenda-frame-do-redo) + (lambda (&rest _) (setq redone t)))) + (cj/--agenda-frame-safe-redo) + (should-not redone)))) + +(ert-deftest test-org-agenda-frame-install-keys-rebinds-f8-family () + "Normal: S-<f8> toggles the frame; the force-rescan moves to C-M-<f8>." + (let ((map (make-sparse-keymap))) + (cj/--agenda-frame-install-keys map) + (should (eq (lookup-key map (kbd "S-<f8>")) 'cj/agenda-frame-toggle)) + (should (eq (lookup-key map (kbd "C-M-<f8>")) 'cj/org-agenda-refresh-files)))) + +(provide 'test-org-agenda-frame) +;;; test-org-agenda-frame.el ends here diff --git a/tests/test-org-refile-config--advice-helpers.el b/tests/test-org-refile-config--advice-helpers.el new file mode 100644 index 00000000..0d9979d8 --- /dev/null +++ b/tests/test-org-refile-config--advice-helpers.el @@ -0,0 +1,87 @@ +;;; test-org-refile-config--advice-helpers.el --- Tests for the refile advice helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for the two named advice helpers extracted from anonymous lambdas +;; in the org-refile use-package :config block: +;; +;; cj/org-refile--save-all-buffers (:after org-refile) +;; cj/org-refile--ensure-targets-in-org-mode (:before org-refile-get-targets) +;; +;; They were anonymous `(lambda (&rest _) ...)' advices, which cannot be +;; `advice-remove'd by reference and cannot be tested. Naming them makes both +;; possible. The install-by-reference and removability are verified live in the +;; daemon (the :config block doesn't run under batch make test); these tests +;; pin the extracted logic. +;; +;; Test organization: +;; - Normal Cases: ensure-targets visits each string-named target +;; - Boundary Cases: empty targets, non-string cars, mixed list +;; - Error Cases: a nil target list is a no-op +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-refile-config) + +;; The module's bare `(defvar org-refile-targets)' marks the symbol special only +;; within its own file, so it isn't special here. Declare it (with a value) so +;; the `let' bindings below bind it dynamically, the way the sibling +;; test-org-refile-config-commands.el does. +(defvar org-refile-targets nil) + +;;; cj/org-refile--ensure-targets-in-org-mode + +(ert-deftest test-org-refile-ensure-targets-visits-each-string-target () + "Normal: every string-named target file is passed to the ensure helper." + (let ((org-refile-targets '(("/a.org" :maxlevel . 3) + ("/b.org" :maxlevel . 3))) + (seen '())) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) + (lambda (f) (push f seen)))) + (cj/org-refile--ensure-targets-in-org-mode)) + (should (equal '("/a.org" "/b.org") (nreverse seen))))) + +;;; Boundary + +(ert-deftest test-org-refile-ensure-targets-skips-non-string-cars () + "Boundary: a target whose car is not a string (a function/symbol spec) is +skipped rather than passed to the ensure helper." + (let ((org-refile-targets `((,(lambda () '("/x.org")) :maxlevel . 2) + ("/real.org" :maxlevel . 2) + (org-agenda-files :maxlevel . 2))) + (seen '())) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) + (lambda (f) (push f seen)))) + (cj/org-refile--ensure-targets-in-org-mode)) + (should (equal '("/real.org") seen)))) + +(ert-deftest test-org-refile-ensure-targets-empty-list-is-noop () + "Boundary: no targets means the ensure helper is never called." + (let ((org-refile-targets '()) + (called nil)) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) + (lambda (_f) (setq called t)))) + (cj/org-refile--ensure-targets-in-org-mode)) + (should-not called))) + +;;; Error + +(ert-deftest test-org-refile-ensure-targets-nil-targets-does-not-signal () + "Error: a nil `org-refile-targets' completes without signaling." + (let ((org-refile-targets nil)) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) #'ignore)) + (should (progn (cj/org-refile--ensure-targets-in-org-mode) t))))) + +;;; cj/org-refile--save-all-buffers + +(ert-deftest test-org-refile-save-all-buffers-delegates () + "Normal: the save helper calls `org-save-all-org-buffers'." + (let ((called nil)) + (cl-letf (((symbol-function 'org-save-all-org-buffers) + (lambda (&rest _) (setq called t)))) + (cj/org-refile--save-all-buffers)) + (should called))) + +(provide 'test-org-refile-config--advice-helpers) +;;; test-org-refile-config--advice-helpers.el ends here diff --git a/tests/test-org-roam-config-format.el b/tests/test-org-roam-config-format.el index e9378b7a..16370ca1 100644 --- a/tests/test-org-roam-config-format.el +++ b/tests/test-org-roam-config-format.el @@ -147,5 +147,21 @@ Returns the formatted file content." (let ((result (test-format "Title" "id" "* Content"))) (should (string-match-p "#\\+FILETAGS: Topic\n\n\\* Content" result)))) +(defvar org-roam-capture-templates) + +(ert-deftest test-org-roam-config-immediate-insert-binding-is-dynamic () + "Normal: the immediate-insert template binding reaches the insert call. +Without the module's defvar, the byte-compiled let is a dead lexical +binding: org-roam-node-insert would see the untouched global templates +and :immediate-finish never applies -- the \"immediate\" insert opens a +capture buffer. Asserted behaviorally (not via special-variable-p, +whose answer differs between the package-loaded and bare batch envs)." + (let ((org-roam-capture-templates '(("d" "default"))) + seen) + (cl-letf (((symbol-function 'org-roam-node-insert) + (lambda (&rest _) (setq seen org-roam-capture-templates)))) + (cj/org-roam-node-insert-immediate nil)) + (should (equal seen '(("d" "default" :immediate-finish t)))))) + (provide 'test-org-roam-config-format) ;;; test-org-roam-config-format.el ends here diff --git a/tests/test-pre-commit-hook.bats b/tests/test-pre-commit-hook.bats new file mode 100644 index 00000000..413c71d0 --- /dev/null +++ b/tests/test-pre-commit-hook.bats @@ -0,0 +1,126 @@ +#!/usr/bin/env bats +# Tests for githooks/pre-commit — the secret scan and paren check. +# +# The scan reads its input through a pipeline: +# +# added_lines="$(git diff --cached ... | grep '^+' | grep -v '^+++' || true)" +# +# `grep` exits 1 when it matches nothing, which is the ordinary case, so the +# `|| true` has to stay. But with no `pipefail` it also swallows a failure of +# `git diff` itself, and an empty `added_lines` makes the scan search nothing, +# find nothing, and report clean. A gate that passes without looking is the +# failure this file exists to pin: the fail-open test drives a broken `git diff` +# and asserts the hook refuses rather than exiting 0. +# +# Each test builds a throwaway git repo in BATS_TEST_TMPDIR, so nothing touches +# the real repository or its hooks. + +setup() { + HOOK="${BATS_TEST_DIRNAME}/../githooks/pre-commit" + REPO="${BATS_TEST_TMPDIR}/repo" + mkdir -p "$REPO" + cd "$REPO" || return 1 + git init -q . + git config user.email t@example.com + git config user.name Test + # Split so the fixtures never appear as credential-shaped literals here. + AWS_TAIL="IOSFODNN7EXAMPLE" + WORD_TAIL="word" +} + +# Put a stub `git` ahead of the real one that fails for the staged-diff call +# and delegates everything else, so only the pipeline under test breaks. +break_staged_diff() { + mkdir -p "${BATS_TEST_TMPDIR}/bin" + cat > "${BATS_TEST_TMPDIR}/bin/git" <<'STUB' +#!/usr/bin/env bash +if [ "${1:-}" = "diff" ] && [ "${2:-}" = "--cached" ] && [ "${3:-}" = "-U0" ]; then + echo "simulated git failure" >&2 + exit 128 +fi +exec /usr/bin/git "$@" +STUB + chmod +x "${BATS_TEST_TMPDIR}/bin/git" + PATH="${BATS_TEST_TMPDIR}/bin:$PATH" +} + +# ------------------------------- Normal cases ------------------------------- + +@test "secret scan: blocks a staged AWS key" { + # Assembled at runtime: a literal key-shaped string in this file would trip + # the very hook under test on every commit that touches it, and this repo + # mirrors to a public remote. + printf 'aws = "%s"\n' "AKIA${AWS_TAIL}" > creds.txt + git add creds.txt + run "$HOOK" + [ "$status" -eq 1 ] + [[ "$output" == *"potential secret"* ]] +} + +@test "secret scan: blocks a staged keyword=value password" { + printf '%s = "%s"\n' "pass${WORD_TAIL}" "correcthorsebatterystaple" > conf.txt + git add conf.txt + run "$HOOK" + [ "$status" -eq 1 ] + [[ "$output" == *"potential secret"* ]] +} + +@test "secret scan: allows an ordinary staged file" { + printf 'just some prose\n' > notes.txt + git add notes.txt + run "$HOOK" + [ "$status" -eq 0 ] +} + +# ------------------------------ Boundary cases ------------------------------ + +@test "secret scan: allows a commit with nothing staged" { + run "$HOOK" + [ "$status" -eq 0 ] +} + +@test "paren check: blocks an unbalanced staged .el file" { + printf '(defun broken ()\n (message "no close"\n' > bad.el + git add bad.el + run "$HOOK" + [ "$status" -eq 1 ] + [[ "$output" == *"paren check failed"* ]] +} + +@test "paren check: allows a balanced staged .el file" { + printf '(defun fine ()\n (message "ok"))\n' > good.el + git add good.el + run "$HOOK" + [ "$status" -eq 0 ] +} + +# -------------------------------- Error cases ------------------------------- + +@test "secret scan: refuses to pass when the staged diff cannot be read" { + # The scan must not report clean after searching nothing. Without a + # pipefail-aware guard the broken diff yields an empty added_lines and the + # hook exits 0, letting a real secret through unscanned. + printf 'aws = "%s"\n' "AKIA${AWS_TAIL}" > creds.txt + git add creds.txt + break_staged_diff + run "$HOOK" + [ "$status" -ne 0 ] +} + +@test "paren check: refuses to pass when the staged file list cannot be read" { + printf '(defun broken ()\n (message "no close"\n' > bad.el + git add bad.el + mkdir -p "${BATS_TEST_TMPDIR}/bin2" + cat > "${BATS_TEST_TMPDIR}/bin2/git" <<'STUB' +#!/usr/bin/env bash +if [ "${1:-}" = "diff" ] && [ "${2:-}" = "--cached" ] && [ "${3:-}" = "--name-only" ]; then + echo "simulated git failure" >&2 + exit 128 +fi +exec /usr/bin/git "$@" +STUB + chmod +x "${BATS_TEST_TMPDIR}/bin2/git" + PATH="${BATS_TEST_TMPDIR}/bin2:$PATH" + run "$HOOK" + [ "$status" -ne 0 ] +} diff --git a/tests/test-prog-c--tool-warnings.el b/tests/test-prog-c--tool-warnings.el new file mode 100644 index 00000000..9d4da57e --- /dev/null +++ b/tests/test-prog-c--tool-warnings.el @@ -0,0 +1,34 @@ +;;; test-prog-c--tool-warnings.el --- Load-time missing-tool warnings -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit flagged clangd for the load-time missing-tool +;; warning pyright/prettier already have. clang-format is the same +;; class: its use-package block gates on `:if (executable-find ...)', +;; which evaluates once at startup, so an absent binary silently +;; disables the format key until the next restart — the warn is the +;; only visible trace. + +;;; 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)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-c) + +(ert-deftest test-prog-c-warns-when-tools-missing () + "Error: loading without the C tools on PATH warns for each one." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-c.el" user-emacs-directory) nil t)) + (dolist (tool '("clangd" "clang-format")) + (should (cl-some (lambda (m) (string-match-p (regexp-quote tool) m)) + warned))))) + +(provide 'test-prog-c--tool-warnings) +;;; test-prog-c--tool-warnings.el ends here diff --git a/tests/test-prog-general--pin-go-treesit-revision.el b/tests/test-prog-general--pin-go-treesit-revision.el new file mode 100644 index 00000000..42845b4f --- /dev/null +++ b/tests/test-prog-general--pin-go-treesit-revision.el @@ -0,0 +1,51 @@ +;;; test-prog-general--pin-go-treesit-revision.el --- Go grammar pinning -*- lexical-binding: t; -*- + +;;; Commentary: +;; The treesit-auto Go recipe is pinned for compatibility with Emacs 30.2. +;; Keep the mutation independent of cl-defstruct's compile-time setter +;; expansion: prog-general is loaded before treesit-auto defines that setter +;; during a normal startup. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; Deliberately put `revision' at a different offset from treesit-auto's real +;; struct. The production helper must discover the slot rather than hard-code +;; the package's current vector layout. +(cl-defstruct treesit-auto-recipe lang revision url) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +(ert-deftest test-prog-general-pin-go-treesit-revision-updates-go () + "Normal: the Go recipe receives the supported grammar revision." + (let* ((go (make-treesit-auto-recipe + :lang 'go :revision "main" :url "https://example.test/go")) + (python (make-treesit-auto-recipe + :lang 'python :revision "main" + :url "https://example.test/python"))) + (cj/treesit-auto-pin-go-revision (list python go)) + (should (equal (treesit-auto-recipe-revision go) "v0.19.1")) + (should (equal (treesit-auto-recipe-revision python) "main")))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-no-go-is-no-op () + "Boundary: a recipe list without Go remains unchanged." + (let ((python (make-treesit-auto-recipe + :lang 'python :revision "main" + :url "https://example.test/python"))) + (should-not (cj/treesit-auto-pin-go-revision (list python))) + (should (equal (treesit-auto-recipe-revision python) "main")))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-empty-is-no-op () + "Boundary: an empty recipe list does not signal an error." + (should-not (cj/treesit-auto-pin-go-revision nil))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-malformed-recipe-errors () + "Error: a malformed recipe signals instead of silently skipping the pin." + (should-error (cj/treesit-auto-pin-go-revision '(not-a-recipe)) + :type 'wrong-type-argument)) + +(provide 'test-prog-general--pin-go-treesit-revision) +;;; test-prog-general--pin-go-treesit-revision.el ends here diff --git a/tests/test-prog-go--classic-mode-hooks.el b/tests/test-prog-go--classic-mode-hooks.el new file mode 100644 index 00000000..a9defe2e --- /dev/null +++ b/tests/test-prog-go--classic-mode-hooks.el @@ -0,0 +1,46 @@ +;;; test-prog-go--classic-mode-hooks.el --- Classic go-mode hooks + gopls warn -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found the Go setup hooks attached to go-ts-mode +;; only, so a fallback to classic go-mode silently lost indent, keys, +;; and LSP. It also flagged gopls for the load-time missing-tool +;; warning pyright/prettier already have; that warn is only honest if +;; ~/go/bin is on `exec-path' at load time (it used to join only in +;; go-mode's deferred :config, so gopls installed there read as +;; missing). + +;;; 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)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-go) + +(ert-deftest test-prog-go-hooks-cover-classic-go-mode () + "Normal: classic go-mode runs the same setup + keybindings as go-ts-mode." + (dolist (hook '(go-mode-hook go-ts-mode-hook)) + (should (memq #'cj/go-setup (symbol-value hook))) + (should (memq #'cj/go-mode-keybindings (symbol-value hook))))) + +(ert-deftest test-prog-go-bin-path-on-exec-path-at-load () + "Normal: ~/go/bin joins `exec-path' at module load, not first go buffer. +The load-time gopls warn resolves through `exec-path'; registering the +Go bin directory only in go-mode's deferred :config would make gopls +installed there warn as missing on every start." + (should (member go-bin-path exec-path))) + +(ert-deftest test-prog-go-warns-when-gopls-missing () + "Error: loading the module without gopls on PATH warns about gopls." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-go.el" user-emacs-directory) nil t)) + (should (cl-some (lambda (m) (string-match-p "gopls" m)) warned)))) + +(provide 'test-prog-go--classic-mode-hooks) +;;; test-prog-go--classic-mode-hooks.el ends here diff --git a/tests/test-prog-shell--tool-warnings.el b/tests/test-prog-shell--tool-warnings.el new file mode 100644 index 00000000..37c1e559 --- /dev/null +++ b/tests/test-prog-shell--tool-warnings.el @@ -0,0 +1,34 @@ +;;; test-prog-shell--tool-warnings.el --- Load-time missing-tool warnings -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit flagged bash-language-server, shfmt, and shellcheck +;; for the load-time missing-tool warnings pyright/prettier already +;; have. The shfmt and flycheck use-package blocks gate on `:if +;; (executable-find ...)', which evaluates once at startup — an absent +;; tool silently disables that setup until the next restart, so the +;; warn is the only visible trace. + +;;; 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)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-shell) + +(ert-deftest test-prog-shell-warns-when-tools-missing () + "Error: loading without the shell tools on PATH warns for each one." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-shell.el" user-emacs-directory) nil t)) + (dolist (tool '("bash-language-server" "shfmt" "shellcheck")) + (should (cl-some (lambda (m) (string-match-p (regexp-quote tool) m)) + warned))))) + +(provide 'test-prog-shell--tool-warnings) +;;; test-prog-shell--tool-warnings.el ends here diff --git a/tests/test-prog-webdev--classic-and-web-mode-hooks.el b/tests/test-prog-webdev--classic-and-web-mode-hooks.el new file mode 100644 index 00000000..20fc2fb8 --- /dev/null +++ b/tests/test-prog-webdev--classic-and-web-mode-hooks.el @@ -0,0 +1,78 @@ +;;; test-prog-webdev--classic-and-web-mode-hooks.el --- Classic js + web-mode setup hooks -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found the webdev setup hooks attached to the +;; tree-sitter modes only, so a grammar-unavailable fallback to classic +;; js-mode silently lost indent/keys/LSP, and web-mode got the format +;; key but none of the promised setup (no company/flyspell/LSP in HTML +;; buffers). These tests pin the classic js-mode hooks and the +;; web-mode setup hook, plus the html-language-server guard that keeps +;; LSP silent on machines without the server. + +;;; 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)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-webdev) + +(ert-deftest test-prog-webdev-hooks-cover-classic-js-mode () + "Normal: classic js-mode runs the same setup + keybindings as js-ts-mode." + (should (memq #'cj/webdev-setup js-mode-hook)) + (should (memq #'cj/webdev-keybindings js-mode-hook))) + +(ert-deftest test-prog-webdev-web-mode-hook-runs-setup () + "Normal: web-mode runs `cj/web-mode-setup' alongside the keybindings." + (should (memq #'cj/web-mode-setup web-mode-hook)) + (should (memq #'cj/webdev-keybindings web-mode-hook))) + +(ert-deftest test-prog-webdev-web-mode-setup-sets-buffer-local-preferences () + "Normal: web-mode setup lands the shared webdev buffer preferences." + (with-temp-buffer + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) + (cj/web-mode-setup)) + (should (= fill-column 100)) + (should (= tab-width 2)) + (should-not indent-tabs-mode))) + +(ert-deftest test-prog-webdev-web-mode-setup-starts-lsp-when-html-server-on-path () + "Normal: with the html language server on PATH, `lsp-deferred' fires." + (with-temp-buffer + (let ((started nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'lsp-deferred) + (lambda (&rest _) (setq started t))) + ((symbol-function 'executable-find) + (lambda (path &rest _) + (when (equal path html-language-server-path) + "/usr/bin/vscode-html-language-server")))) + (cj/web-mode-setup)) + (should started)))) + +(ert-deftest test-prog-webdev-web-mode-setup-skips-lsp-without-html-server () + "Boundary: without the html language server, `lsp-deferred' is NOT called." + (with-temp-buffer + (let ((started nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'lsp-deferred) + (lambda (&rest _) (setq started t))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) + (cj/web-mode-setup)) + (should-not started)))) + +(provide 'test-prog-webdev--classic-and-web-mode-hooks) +;;; test-prog-webdev--classic-and-web-mode-hooks.el ends here diff --git a/tests/test-restclient-config--keymap.el b/tests/test-restclient-config--keymap.el new file mode 100644 index 00000000..7265c4f3 --- /dev/null +++ b/tests/test-restclient-config--keymap.el @@ -0,0 +1,29 @@ +;;; test-restclient-config--keymap.el --- Tests for the restclient prefix keymap -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins the C-; R prefix wiring. The bindings must go through +;; `cj/restclient-map' + `cj/register-prefix-map' (like the other C-; +;; prefixes), not raw `global-set-key' calls that silently depend on +;; keybindings.el having installed C-; first. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'restclient-config) + +;;; Normal Cases + +(ert-deftest test-restclient-keymap-registered-under-custom-prefix () + "Normal: cj/restclient-map is bound at R inside cj/custom-keymap." + (should (boundp 'cj/restclient-map)) + (should (eq cj/restclient-map (keymap-lookup cj/custom-keymap "R")))) + +(ert-deftest test-restclient-keymap-binds-new-buffer-and-open-file () + "Normal: the prefix map carries the two restclient commands." + (should (eq #'cj/restclient-new-buffer (keymap-lookup cj/restclient-map "n"))) + (should (eq #'cj/restclient-open-file (keymap-lookup cj/restclient-map "o")))) + +(provide 'test-restclient-config--keymap) +;;; test-restclient-config--keymap.el ends here diff --git a/tests/test-slack-config-reactions.el b/tests/test-slack-config-reactions.el index 491b8147..bfcf3e29 100644 --- a/tests/test-slack-config-reactions.el +++ b/tests/test-slack-config-reactions.el @@ -92,5 +92,13 @@ (let ((slack-current-buffer nil)) (should-error (cj/slack-message-add-reaction) :type 'user-error))) +(ert-deftest test-slack-config-message-add-reaction-errors-before-slack-loads () + "Error: a cold call before slack.el ever loads gives the friendly user-error. +The module defvars slack-current-buffer with no value, so until slack.el +binds it the variable is void -- a bare read signals void-variable instead +of the intended \"Not in a Slack buffer\"." + (makunbound 'slack-current-buffer) + (should-error (cj/slack-message-add-reaction) :type 'user-error)) + (provide 'test-slack-config-reactions) ;;; test-slack-config-reactions.el ends here diff --git a/tests/test-system-commands-resolve-and-run.el b/tests/test-system-commands-resolve-and-run.el index 9d92c5d6..7e5146b1 100644 --- a/tests/test-system-commands-resolve-and-run.el +++ b/tests/test-system-commands-resolve-and-run.el @@ -230,5 +230,37 @@ kill-emacs directly (the service owns the daemon lifecycle)." (cj/system-command-menu)) (should (eq called 'cj/system-cmd-lock)))) +;;; Lock command resolves the locker at call time + +(defun test-system-cmd--run-lock-capturing () + "Run the lock command; return the shell command line it launched." + (let (cmd-line) + (cl-letf (((symbol-function 'start-process-shell-command) + (lambda (_name _buf c) (setq cmd-line c) 'fake-proc)) + ((symbol-function 'set-process-query-on-exit-flag) #'ignore) + ((symbol-function 'set-process-sentinel) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/system-cmd-lock)) + cmd-line)) + +(ert-deftest test-system-cmd-lock-follows-session-type-at-call-time () + "Normal: the locker tracks the live session type, not the load-time bake. +A daemon started before WAYLAND_DISPLAY was imported used to freeze the +locker to slock forever; Lock then failed silently on Wayland." + (let ((lockscreen-cmd nil)) + (cl-letf (((symbol-function 'env-wayland-p) (lambda () t))) + (should (string-match-p "loginctl lock-session" + (test-system-cmd--run-lock-capturing)))) + (cl-letf (((symbol-function 'env-wayland-p) (lambda () nil))) + (should (string-match-p "slock" + (test-system-cmd--run-lock-capturing)))))) + +(ert-deftest test-system-cmd-lock-explicit-override-wins () + "Boundary: a user-set lockscreen-cmd overrides the session-type resolution." + (let ((lockscreen-cmd "my-locker --now")) + (cl-letf (((symbol-function 'env-wayland-p) (lambda () t))) + (should (string-match-p "my-locker --now" + (test-system-cmd--run-lock-capturing)))))) + (provide 'test-system-commands-resolve-and-run) ;;; test-system-commands-resolve-and-run.el ends here diff --git a/tests/test-system-defaults-functions.el b/tests/test-system-defaults-functions.el index c603fc7e..4b647166 100644 --- a/tests/test-system-defaults-functions.el +++ b/tests/test-system-defaults-functions.el @@ -162,5 +162,36 @@ and the rendered S-expression lands in the log." (should (string-match-p ":slot" contents))))) (delete-file comp-warnings-log)))) +(ert-deftest test-system-defaults-log-comp-warning-unwritable-log-does-not-signal () + "Error: an unwritable log path must not signal. +The function is `:before-until' advice on `display-warning'; a signal here +propagates out of `display-warning' and breaks warning display for every +async native-comp notice. It swallows the write failure and still returns +t (the warning stays suppressed), rather than crashing." + (let ((comp-warnings-log "/proc/nonexistent-dir/cannot-write.log")) + (should (eq t (cj/log-comp-warning 'comp "boom"))))) + +(ert-deftest test-system-defaults-log-comp-warning-caps-log-growth () + "Boundary: the log is bounded — once it exceeds the cap, a further write +resets it (deletes the old file, keeping only the new entry) rather than +growing without limit. A hard reset, not a tail-trim: on overflow the old +history is discarded, which is fine for a transient diagnostic log." + (let ((comp-warnings-log (make-temp-file "comp-warnings-" nil ".log"))) + (unwind-protect + (progn + ;; Seed the file well over the cap. + (with-temp-file comp-warnings-log + (insert (make-string (1+ cj/comp-warnings-log-max-bytes) ?x))) + (should (> (file-attribute-size (file-attributes comp-warnings-log)) + cj/comp-warnings-log-max-bytes)) + (cj/log-comp-warning 'comp "after the cap") + (should (<= (file-attribute-size (file-attributes comp-warnings-log)) + cj/comp-warnings-log-max-bytes)) + ;; The newest entry survives the trim. + (with-temp-buffer + (insert-file-contents comp-warnings-log) + (should (string-match-p "after the cap" (buffer-string))))) + (delete-file comp-warnings-log)))) + (provide 'test-system-defaults-functions) ;;; test-system-defaults-functions.el ends here diff --git a/tests/test-system-lib--ensure-marginalia-align.el b/tests/test-system-lib--ensure-marginalia-align.el new file mode 100644 index 00000000..33ff2ba2 --- /dev/null +++ b/tests/test-system-lib--ensure-marginalia-align.el @@ -0,0 +1,57 @@ +;;; test-system-lib--ensure-marginalia-align.el --- Tests for marginalia category registration -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Custom completion categories (cj-music-file, cj-radio-station, and every +;; category passed to the system-lib table helpers) bypass marginalia, so +;; their annotations never get its right-alignment even with marginalia-align +;; set. The registration helper adds a builtin entry per category so the +;; table's own annotation function renders through marginalia's aligned field. + +;;; Code: + +(require 'ert) + +;; The module's bare defvar marks this special only file-locally; declare it +;; here too so `let' binds dynamically (the scope-shadowing trap). +(defvar marginalia-annotator-registry) + +(require 'system-lib) + +;;; Normal Cases + +(ert-deftest test-system-lib-ensure-marginalia-align-registers-category () + "Normal: an unregistered category gains a builtin registry entry." + (let ((marginalia-annotator-registry '((file some-annotator builtin none)))) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (should (equal (assq 'cj-test-category marginalia-annotator-registry) + '(cj-test-category builtin none))))) + +(ert-deftest test-system-lib-ensure-marginalia-align-idempotent () + "Normal: registering the same category twice leaves one entry." + (let ((marginalia-annotator-registry '())) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (should (= 1 (length marginalia-annotator-registry))))) + +;;; Boundary Cases + +(ert-deftest test-system-lib-ensure-marginalia-align-preserves-existing-entry () + "Boundary: a category with an existing (possibly custom) entry is untouched." + (let ((marginalia-annotator-registry '((cj-test-category my-custom-annotator)))) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (should (equal (assq 'cj-test-category marginalia-annotator-registry) + '(cj-test-category my-custom-annotator))))) + +;;; Error Cases + +(ert-deftest test-system-lib-ensure-marginalia-align-marginalia-absent-noop () + "Error: without marginalia loaded (registry void) the helper is a silent +no-op -- annotations just stay unaligned, nothing breaks." + ;; marginalia is not loadable in the batch environment, so the global + ;; registry is genuinely void outside the `let's above. + (should-not (cj/completion-ensure-marginalia-align 'cj-test-category))) + +(provide 'test-system-lib--ensure-marginalia-align) +;;; test-system-lib--ensure-marginalia-align.el ends here diff --git a/tests/test-test-runner--nil-global-directory.el b/tests/test-test-runner--nil-global-directory.el new file mode 100644 index 00000000..c70de5bd --- /dev/null +++ b/tests/test-test-runner--nil-global-directory.el @@ -0,0 +1,51 @@ +;;; test-test-runner--nil-global-directory.el --- Tests for the no-test-directory path -*- lexical-binding: t -*- + +;;; Commentary: +;; Outside a Projectile project, `cj/test--get-test-directory' falls back +;; to `cj/test-global-directory', which defaults to nil. These tests pin +;; the contract for that nil case: discovery helpers return nil instead +;; of crashing on (file-directory-p nil), and the interactive commands +;; signal `user-error' instead of wrong-type-argument. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'test-runner) + +(defmacro test-runner-nil-dir--outside-project (&rest body) + "Run BODY with no project root and a nil `cj/test-global-directory'." + (declare (indent 0)) + `(let ((cj/test-global-directory nil)) + (cl-letf (((symbol-function 'cj/test--project-root) + (lambda () nil))) + ,@body))) + +;;; Boundary Cases + +(ert-deftest test-test-runner-nil-dir-get-test-directory-returns-nil () + "Boundary: no project and no global dir yields nil, not an error." + (test-runner-nil-dir--outside-project + (should (null (cj/test--get-test-directory))))) + +(ert-deftest test-test-runner-nil-dir-get-test-files-returns-nil () + "Boundary: file discovery returns nil instead of crashing on a nil dir." + (test-runner-nil-dir--outside-project + (should (null (cj/test--get-test-files))))) + +;;; Error Cases + +(ert-deftest test-test-runner-nil-dir-load-all-signals-user-error () + "Error: `cj/test-load-all' signals `user-error', not wrong-type-argument." + (test-runner-nil-dir--outside-project + (should-error (cj/test-load-all) :type 'user-error))) + +(ert-deftest test-test-runner-nil-dir-focus-add-signals-user-error () + "Error: `cj/test-focus-add' signals `user-error', not wrong-type-argument." + (test-runner-nil-dir--outside-project + (should-error (cj/test-focus-add) :type 'user-error))) + +(provide 'test-test-runner--nil-global-directory) +;;; test-test-runner--nil-global-directory.el ends here diff --git a/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el b/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el index 36d82add..bcb9f833 100644 --- a/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el +++ b/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el @@ -158,5 +158,22 @@ (kill-buffer buf)))))) (test-kill-all-other-buffers-and-windows-teardown))) +(ert-deftest test-kill-all-other-buffers-and-windows-with-prefix-still-kills () + "Boundary: C-u on the wrapper must still kill, not spam the undead list. +The delegated cj/kill-buffer-or-bury-alive reads current-prefix-arg, so a +prefixed wrapper call used to take the add-to-undead-list branch for every +buffer -- nothing killed, list spammed." + (test-kill-all-other-buffers-and-windows-setup) + (unwind-protect + (let ((cj/undead-buffer-list cj/undead-buffer-list) + (buf (generate-new-buffer "*test-prefix-kill*"))) + (unwind-protect + (let ((current-prefix-arg '(4))) + (cj/kill-all-other-buffers-and-windows) + (should-not (buffer-live-p buf)) + (should-not (member "*test-prefix-kill*" cj/undead-buffer-list))) + (when (buffer-live-p buf) (kill-buffer buf)))) + (test-kill-all-other-buffers-and-windows-teardown))) + (provide 'test-undead-buffers-kill-all-other-buffers-and-windows) ;;; test-undead-buffers-kill-all-other-buffers-and-windows.el ends here diff --git a/tests/test-validate-el-hook.bats b/tests/test-validate-el-hook.bats new file mode 100644 index 00000000..43c3569c --- /dev/null +++ b/tests/test-validate-el-hook.bats @@ -0,0 +1,97 @@ +#!/usr/bin/env bats +# Tests for .claude/hooks/validate-el.sh — the auto-test runner. +# +# The runner used to skip entirely above MAX_AUTO_TEST_FILES=20, with no else +# branch: nothing printed, exit 0, indistinguishable from a passing run. That +# was live for the three largest families here (calendar-sync 63 test files, +# music 45, ai-term 35), so every edit to those ran parens and byte-compile and +# zero tests, silently. +# +# The cap was removed rather than made loud, because its premise did not hold. +# Measured on this machine, running a whole family takes about a second: +# ai-term 208 tests in 1.0s, music 403 in 1.7s, calendar-sync 633 in 0.9s. It +# was also concealing a real cross-test pollution bug in calendar-sync that +# only appears when that family runs in one process. +# +# These tests pin that no file count is skipped. Each builds a synthetic +# project in BATS_TEST_TMPDIR and points CLAUDE_PROJECT_DIR at it, so nothing +# runs against the real tree. + +setup() { + HOOK="${BATS_TEST_DIRNAME}/../.claude/hooks/validate-el.sh" + PROJ="${BATS_TEST_TMPDIR}/proj" + mkdir -p "$PROJ/modules" "$PROJ/tests" + export CLAUDE_PROJECT_DIR="$PROJ" + printf '(provide (quote widget))\n' > "$PROJ/modules/widget.el" +} + +# N green test files matching the widget stem. +make_tests() { + local n="$1" i + for ((i = 1; i <= n; i++)); do + printf '(require (quote ert))\n(ert-deftest test-widget-%d () (should t))\n' \ + "$i" > "$PROJ/tests/test-widget-${i}.el" + done +} + +# One failing test file, to prove the run is real rather than merely quiet. +make_failing_test() { + printf '(require (quote ert))\n(ert-deftest test-widget-bad () (should nil))\n' \ + > "$PROJ/tests/test-widget-bad.el" +} + +hook_input() { + printf '{"tool_input":{"file_path":"%s"}}' "$PROJ/modules/widget.el" +} + +run_hook() { + run bash -c "$(printf '%q' "$HOOK") <<< '$(hook_input)'" +} + +# ------------------------------- Normal cases ------------------------------- + +@test "a small family runs and passes quietly" { + make_tests 3 + run_hook + [ "$status" -eq 0 ] +} + +@test "a failing test blocks, so a quiet pass means the tests really ran" { + make_tests 3 + make_failing_test + run_hook + [ "$status" -eq 2 ] + [[ "$output" == *"TESTS FAILED"* ]] +} + +# ------------------------------ Boundary cases ------------------------------ + +@test "at the old cap of 20 files: runs" { + make_tests 20 + run_hook + [ "$status" -eq 0 ] +} + +@test "past the old cap: still runs, no longer skipped" { + make_tests 21 + run_hook + [ "$status" -eq 0 ] + [[ "${output,,}" != *"skipped"* ]] +} + +@test "well past the old cap: a failure in file 63 is still caught" { + # The regression this guards: at 63 files the runner used to skip, so a red + # test in a big family reported clean. calendar-sync is exactly this size. + make_tests 63 + make_failing_test + run_hook + [ "$status" -eq 2 ] + [[ "$output" == *"TESTS FAILED"* ]] +} + +# -------------------------------- Error cases ------------------------------- + +@test "no matching tests: exits clean without running anything" { + run_hook + [ "$status" -eq 0 ] +} diff --git a/tests/test-vc-config--git-clone.el b/tests/test-vc-config--git-clone.el index 3b39ece2..46ce3d40 100644 --- a/tests/test-vc-config--git-clone.el +++ b/tests/test-vc-config--git-clone.el @@ -2,9 +2,11 @@ ;;; Commentary: ;; Unit tests for cj/--git-clone-dir-name (robust repo-dir derivation across -;; HTTPS, scp-style SSH, ssh:// and local URLs) and for cj/git-clone-clipboard-url -;; reporting a failed clone from the process exit status instead of silently -;; assuming the directory appeared. +;; HTTPS, scp-style SSH, ssh:// and local URLs), for the async clone process +;; wiring in cj/git-clone-clipboard-url (make-process argv, no shell), and +;; for the sentinel built by cj/--git-clone-make-sentinel (open on success, +;; surface the process buffer on failure). Sentinel tests drive real +;; short-lived processes rather than mocking process primitives. ;;; Code: @@ -14,6 +16,18 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'vc-config) +(defun test-vc-clone--run-sentinel (command sentinel buffer) + "Run COMMAND with SENTINEL and BUFFER; wait for process exit." + (let ((proc (make-process :name "test-vc-clone" + :buffer buffer + :command command + :sentinel sentinel))) + (while (process-live-p proc) + (accept-process-output proc 0.05)) + ;; Give the sentinel a chance to run after exit. + (accept-process-output nil 0.05) + proc)) + ;;; cj/--git-clone-dir-name — Normal Cases (ert-deftest test-vc-git-clone-dir-name-https-with-git-suffix () @@ -36,7 +50,7 @@ (should (equal "repo" (cj/--git-clone-dir-name "ssh://git@example.com/user/repo.git")))) -;;; Boundary Cases +;;; cj/--git-clone-dir-name — Boundary Cases (ert-deftest test-vc-git-clone-dir-name-ssh-scp-without-user () "Boundary: scp-style SSH with no user path (host:repo.git) still works. @@ -60,29 +74,110 @@ since there is no `/' separator." (should (equal "repo" (cj/--git-clone-dir-name " https://example.com/user/repo.git\n")))) -;;; cj/git-clone-clipboard-url — Error Cases +;;; cj/--git-clone-open — Normal / Boundary Cases -(ert-deftest test-vc-git-clone-clipboard-url-reports-clone-failure () - "Error: a nonzero git exit status surfaces a user-error, not silence. -Uses a real writable temp dir as the target (so the file predicates run -for real) and mocks only the clone process to fail." - (let ((target (make-temp-file "cj-clone-fail-" t))) +(ert-deftest test-vc-git-clone-open-finds-readme () + "Normal: a README in the clone is opened." + (let ((dir (make-temp-file "cj-clone-open-" t)) + (opened nil)) + (unwind-protect + (progn + (with-temp-file (expand-file-name "README.md" dir) (insert "hi")) + (cl-letf (((symbol-function 'find-file) + (lambda (f &rest _) (setq opened f))) + ((symbol-function 'dired) #'ignore)) + (cj/--git-clone-open dir) + (should (equal (expand-file-name "README.md" dir) opened)))) + (delete-directory dir t)))) + +(ert-deftest test-vc-git-clone-open-no-readme-dires () + "Boundary: with no README, the clone directory is dired." + (let ((dir (make-temp-file "cj-clone-open-" t)) + (dired-dir nil)) + (unwind-protect + (cl-letf (((symbol-function 'find-file) + (lambda (&rest _) (error "find-file should not run"))) + ((symbol-function 'dired) + (lambda (d &rest _) (setq dired-dir d)))) + (cj/--git-clone-open dir) + (should (equal dir dired-dir))) + (delete-directory dir t)))) + +;;; cj/--git-clone-make-sentinel — Normal / Error Cases + +(ert-deftest test-vc-git-clone-sentinel-success-opens-clone () + "Normal: a zero-exit clone process opens the clone directory." + (let ((buffer (generate-new-buffer " *test-clone-ok*")) + (opened nil)) + (unwind-protect + (cl-letf (((symbol-function 'cj/--git-clone-open) + (lambda (d) (setq opened d))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (test-vc-clone--run-sentinel + '("true") (cj/--git-clone-make-sentinel "url" "/tmp/clone-dst") buffer) + (should (equal "/tmp/clone-dst" opened))) + (kill-buffer buffer)))) + +(ert-deftest test-vc-git-clone-sentinel-failure-pops-process-buffer () + "Error: a nonzero exit surfaces the process buffer, never opens the clone." + (let ((buffer (generate-new-buffer " *test-clone-fail*")) + (opened nil) + (popped nil)) (unwind-protect - (cl-letf (((symbol-function 'call-process) (lambda (&rest _) 128)) - ((symbol-function 'pop-to-buffer) #'ignore) - ((symbol-function 'message) #'ignore)) - (should-error - (cj/git-clone-clipboard-url "https://example.com/user/repo.git" target) - :type 'user-error)) + (cl-letf (((symbol-function 'cj/--git-clone-open) + (lambda (d) (setq opened d))) + ((symbol-function 'pop-to-buffer) + (lambda (b &rest _) (setq popped b))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (test-vc-clone--run-sentinel + '("false") (cj/--git-clone-make-sentinel "url" "/tmp/clone-dst") buffer) + (should-not opened) + (should (eq buffer popped))) + (kill-buffer buffer)))) + +;;; cj/git-clone-clipboard-url — Normal / Error Cases + +(ert-deftest test-vc-git-clone-clipboard-url-spawns-async-argv () + "Normal: the clone runs as an async process with a plain argv, no shell. +The `--' separator must precede the URL so a leading-dash URL cannot be +read as a git flag." + (let ((target (make-temp-file "cj-clone-async-" t)) + (spawned nil)) + (unwind-protect + (cl-letf (((symbol-function 'make-process) + (lambda (&rest args) + (setq spawned (plist-get args :command)) + nil)) + ((symbol-function 'message) (lambda (&rest _) nil))) + (cj/git-clone-clipboard-url "https://example.com/user/repo.git" target) + (should (equal (list "git" "clone" "--" + "https://example.com/user/repo.git" + (expand-file-name "repo" target)) + spawned))) (delete-directory target t)))) (ert-deftest test-vc-git-clone-clipboard-url-empty-clipboard-errors () "Error: an empty clipboard URL aborts before any clone attempt." - (let ((cloned nil)) - (cl-letf (((symbol-function 'call-process) - (lambda (&rest _) (setq cloned t) 0))) + (let ((spawned nil)) + (cl-letf (((symbol-function 'make-process) + (lambda (&rest _) (setq spawned t) nil))) (should-error (cj/git-clone-clipboard-url " " "/tmp") :type 'user-error)) - (should-not cloned))) + (should-not spawned))) + +(ert-deftest test-vc-git-clone-clipboard-url-existing-destination-errors () + "Error: an existing clone destination aborts before any clone attempt." + (let ((target (make-temp-file "cj-clone-exists-" t)) + (spawned nil)) + (unwind-protect + (progn + (make-directory (expand-file-name "repo" target)) + (cl-letf (((symbol-function 'make-process) + (lambda (&rest _) (setq spawned t) nil))) + (should-error + (cj/git-clone-clipboard-url "https://example.com/user/repo.git" target) + :type 'user-error)) + (should-not spawned)) + (delete-directory target t)))) (provide 'test-vc-config--git-clone) ;;; test-vc-config--git-clone.el ends here diff --git a/tests/test-vc-config--gutter-hunk-candidates.el b/tests/test-vc-config--gutter-hunk-candidates.el new file mode 100644 index 00000000..65db0c3c --- /dev/null +++ b/tests/test-vc-config--gutter-hunk-candidates.el @@ -0,0 +1,69 @@ +;;; test-vc-config--gutter-hunk-candidates.el --- Tests for cj/--git-gutter-hunk-candidates -*- lexical-binding: t -*- + +;;; Commentary: +;; Unit tests for cj/--git-gutter-hunk-candidates, the pure helper that +;; builds completion candidates (label . line) from git-gutter hunk start +;; lines against the current buffer's text. The interactive wrapper +;; cj/goto-git-gutter-diff-hunks maps git-gutter:diffinfos onto start +;; lines and delegates here. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'vc-config) + +;;; Normal Cases + +(ert-deftest test-vc-gutter-hunk-candidates-labels-carry-line-text () + "Normal: each candidate label contains the hunk line's text." + (with-temp-buffer + (insert "alpha\nbravo\ncharlie\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(2 3)))) + (should (= 2 (length candidates))) + (should (string-match-p "bravo" (car (nth 0 candidates)))) + (should (string-match-p "charlie" (car (nth 1 candidates))))))) + +(ert-deftest test-vc-gutter-hunk-candidates-cdr-is-start-line () + "Normal: each candidate's cdr is the hunk's start line number." + (with-temp-buffer + (insert "alpha\nbravo\ncharlie\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(1 3)))) + (should (equal '(1 3) (mapcar #'cdr candidates)))))) + +;;; Boundary Cases + +(ert-deftest test-vc-gutter-hunk-candidates-empty-input-returns-nil () + "Boundary: no hunks produce no candidates." + (with-temp-buffer + (insert "alpha\n") + (should (null (cj/--git-gutter-hunk-candidates '()))))) + +(ert-deftest test-vc-gutter-hunk-candidates-first-line () + "Boundary: a hunk on line 1 resolves to the first line's text." + (with-temp-buffer + (insert "alpha\nbravo\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(1)))) + (should (string-match-p "alpha" (caar candidates))) + (should (= 1 (cdar candidates)))))) + +(ert-deftest test-vc-gutter-hunk-candidates-unicode-line-text () + "Boundary: line text with unicode survives into the label." + (with-temp-buffer + (insert "naïve — 日本語\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(1)))) + (should (string-match-p "日本語" (caar candidates)))))) + +;;; Error Cases + +(ert-deftest test-vc-goto-git-gutter-diff-hunks-no-hunks-user-error () + "Error: the command signals `user-error' when the buffer has no hunks." + (with-temp-buffer + (setq-local git-gutter:diffinfos nil) + (cl-letf (((symbol-function 'require) (lambda (&rest _) nil))) + (should-error (cj/goto-git-gutter-diff-hunks) :type 'user-error)))) + +(provide 'test-vc-config--gutter-hunk-candidates) +;;; test-vc-config--gutter-hunk-candidates.el ends here diff --git a/tests/test-vc-config--timemachine-commands.el b/tests/test-vc-config--timemachine-commands.el new file mode 100644 index 00000000..36a71695 --- /dev/null +++ b/tests/test-vc-config--timemachine-commands.el @@ -0,0 +1,36 @@ +;;; test-vc-config--timemachine-commands.el --- Tests for git-timemachine command wiring -*- lexical-binding: t -*- + +;;; Commentary: +;; Guards the git-timemachine autoload surface in vc-config.el. The +;; upstream package defines no `git-timemachine-show-selected-revision'; +;; an autoload for it in :commands creates a phantom M-x command that +;; errors after loading the package. The real selector lives in the +;; cj/ namespace. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'vc-config) + +;;; Normal Cases + +(ert-deftest test-vc-timemachine-selected-revision-cj-command-defined () + "Normal: the cj/ selected-revision selector is defined by vc-config." + (should (fboundp 'cj/git-timemachine-show-selected-revision))) + +(ert-deftest test-vc-timemachine-entry-command-defined () + "Normal: the cj/git-timemachine entry command is defined." + (should (commandp 'cj/git-timemachine))) + +;;; Error Cases + +(ert-deftest test-vc-timemachine-no-phantom-package-autoload () + "Error: no autoload exists for a function the package never defines. +An autoload stub for `git-timemachine-show-selected-revision' would +surface in M-x and signal void-function after the package loads." + (should-not (fboundp 'git-timemachine-show-selected-revision))) + +(provide 'test-vc-config--timemachine-commands) +;;; test-vc-config--timemachine-commands.el ends here diff --git a/tests/test-video-audio-recording-group-devices-by-hardware.el b/tests/test-video-audio-recording-group-devices-by-hardware.el deleted file mode 100644 index 2be4982f..00000000 --- a/tests/test-video-audio-recording-group-devices-by-hardware.el +++ /dev/null @@ -1,194 +0,0 @@ -;;; test-video-audio-recording-group-devices-by-hardware.el --- Tests for cj/recording-group-devices-by-hardware -*- lexical-binding: t; -*- - -;;; Commentary: -;; Unit tests for cj/recording-group-devices-by-hardware function. -;; Tests grouping of audio sources by physical hardware device. -;; Critical test: Bluetooth MAC address normalization (colons vs underscores). -;; -;; This function is used by the quick setup command to automatically pair -;; microphone and monitor devices from the same hardware. - -;;; Code: - -(require 'ert) - -;; Stub dependencies before loading the module -(defvar cj/custom-keymap (make-sparse-keymap) - "Stub keymap for testing.") - -;; Now load the actual production module -(require 'video-audio-recording) - -;;; Test Fixtures Helper - -(defun test-load-fixture (filename) - "Load fixture file FILENAME from tests/fixtures directory." - (let ((fixture-path (expand-file-name - (concat "tests/fixtures/" filename) - user-emacs-directory))) - (with-temp-buffer - (insert-file-contents fixture-path) - (buffer-string)))) - -;;; Normal Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-all-types-grouped () - "Test grouping of all three device types (built-in, USB, Bluetooth). -This is the key test validating the complete grouping logic." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (= 3 (length result))) - ;; Check that we have all three device types - (let ((names (mapcar #'car result))) - (should (member "Built-in Audio" names)) - (should (member "Bluetooth Headset" names)) - (should (member "Jabra SPEAK 510 USB" names))) - ;; Verify each device has both mic and monitor - (dolist (device result) - (should (stringp (car device))) ; friendly name - (should (stringp (cadr device))) ; mic device - (should (stringp (cddr device))) ; monitor device - (should-not (string-suffix-p ".monitor" (cadr device))) ; mic not monitor - (should (string-suffix-p ".monitor" (cddr device)))))))) ; monitor has suffix - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-built-in-paired () - "Test that built-in laptop audio devices are correctly paired." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (built-in (assoc "Built-in Audio" result))) - (should built-in) - (should (string-match-p "pci-0000_00_1f" (cadr built-in))) - (should (string-match-p "pci-0000_00_1f" (cddr built-in))) - (should (equal "alsa_input.pci-0000_00_1f.3.analog-stereo" (cadr built-in))) - (should (equal "alsa_output.pci-0000_00_1f.3.analog-stereo.monitor" (cddr built-in))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-usb-paired () - "Test that USB devices (Jabra) are correctly paired." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (jabra (assoc "Jabra SPEAK 510 USB" result))) - (should jabra) - (should (string-match-p "Jabra" (cadr jabra))) - (should (string-match-p "Jabra" (cddr jabra))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-bluetooth-paired () - "Test that Bluetooth devices are correctly paired. -CRITICAL: Tests MAC address normalization (colons in input, underscores in output)." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (bluetooth (assoc "Bluetooth Headset" result))) - (should bluetooth) - ;; Input has colons: bluez_input.00:1B:66:C0:91:6D - (should (equal "bluez_input.00:1B:66:C0:91:6D" (cadr bluetooth))) - ;; Output has underscores: bluez_output.00_1B_66_C0_91_6D.1.monitor - ;; But they should still be grouped together (MAC address normalized) - (should (equal "bluez_output.00_1B_66_C0_91_6D.1.monitor" (cddr bluetooth))))))) - -;;; Boundary Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-empty-returns-empty () - "Test that empty pactl output returns empty list." - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) ""))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-only-inputs-returns-empty () - "Test that only input devices (no monitors) returns empty list. -Devices must have BOTH mic and monitor to be included." - (let ((output (test-load-fixture "pactl-output-inputs-only.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-only-monitors-returns-empty () - "Test that only monitor devices (no inputs) returns empty list." - (let ((output (test-load-fixture "pactl-output-monitors-only.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-single-complete-device () - "Test that single device with both mic and monitor is returned." - (let ((output "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n")) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - (should (equal "Built-in Audio" (caar result))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-mixed-complete-incomplete () - "Test that only devices with BOTH mic and monitor are included. -Incomplete devices (only mic or only monitor) are filtered out." - (let ((output (concat - ;; Complete device (built-in) - "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - "49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - ;; Incomplete: USB mic with no monitor - "100\talsa_input.usb-device.mono-fallback\tPipeWire\ts16le 1ch 16000Hz\tSUSPENDED\n" - ;; Incomplete: Bluetooth monitor with no mic - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - ;; Only the complete built-in device should be returned - (should (= 1 (length result))) - (should (equal "Built-in Audio" (caar result))))))) - -;;; Error Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-malformed-output-returns-empty () - "Test that malformed pactl output returns empty list." - (let ((output (test-load-fixture "pactl-output-malformed.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-unknown-device-type () - "Test that unknown device types get generic 'USB Audio Device' name." - (let ((output (concat - "100\talsa_input.usb-unknown_device-00.analog-stereo\tPipeWire\ts16le 2ch 16000Hz\tSUSPENDED\n" - "99\talsa_output.usb-unknown_device-00.analog-stereo.monitor\tPipeWire\ts16le 2ch 48000Hz\tSUSPENDED\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - ;; Should get generic USB name (not matching Jabra pattern) - (should (equal "USB Audio Device" (caar result))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-bluetooth-mac-case-variations () - "Test that Bluetooth MAC addresses work with different formatting. -Tests the normalization logic handles various MAC address formats." - (let ((output (concat - ;; Input with colons (typical) - "79\tbluez_input.AA:BB:CC:DD:EE:FF\tPipeWire\tfloat32le 1ch 48000Hz\tSUSPENDED\n" - ;; Output with underscores (typical) - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - (should (equal "Bluetooth Headset" (caar result))) - ;; Verify both devices paired despite different MAC formats - (let ((device (car result))) - (should (string-match-p "AA:BB:CC" (cadr device))) - (should (string-match-p "AA_BB_CC" (cddr device)))))))) - -(provide 'test-video-audio-recording-group-devices-by-hardware) -;;; test-video-audio-recording-group-devices-by-hardware.el ends here diff --git a/tests/test-video-audio-recording-process-sentinel.el b/tests/test-video-audio-recording-process-sentinel.el index 92fb3f0d..d733e46f 100644 --- a/tests/test-video-audio-recording-process-sentinel.el +++ b/tests/test-video-audio-recording-process-sentinel.el @@ -190,5 +190,157 @@ (should (null cj/audio-recording-ffmpeg-process)))) (test-sentinel-teardown))) +;;; Failed-Start Stub Deletion +;; +;; On Wayland a wf-recorder that fails to grab the compositor capture +;; still writes a ~500KB, ~0.5s stub .mkv before dying. The sentinel +;; detects the failed start (exit sooner than +;; `cj/recording-start-fail-threshold' without a user stop); these tests +;; pin that it also deletes the stub file stamped on the process as the +;; `cj-output-file' property — and that normal stops and user stops +;; never delete anything. + +(defun test-sentinel--make-exited-process () + "Return a real process that has already exited. +Drives the sentinel with a genuinely dead process so `process-status' +and the process plist behave for real instead of through mocks." + (let ((proc (make-process :name "test-sentinel-exited" + :command '("true") + :sentinel #'ignore))) + (while (process-live-p proc) + (accept-process-output proc 0.05)) + proc)) + +(defun test-sentinel--make-stub-file () + "Create and return a temp file standing in for the stub .mkv." + (make-temp-file "test-sentinel-stub-" nil ".mkv" "stub-content")) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-failed-start-deletes-stub () + "Normal: a failed video start deletes the stub output file." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file))) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + ;; Exited immediately after its start time — a failed start. + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-output-file stub) + (cj/recording-process-sentinel proc "exited abnormally\n") + (should-not (file-exists-p stub))) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-failed-start-still-messages () + "Normal: the failed-start branch still reports the failure to the user." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file)) + (failure-messaged nil)) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-output-file stub) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) + (let ((msg (apply #'format fmt args))) + (when (string-match-p "failed to start" msg) + (setq failure-messaged t)))))) + (cj/recording-process-sentinel proc "exited abnormally\n")) + (should failure-messaged)) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-long-run-keeps-file () + "Normal: a recording that ran past the threshold keeps its output file." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file))) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + ;; Ran well past the fail threshold — a real recording. + (process-put proc 'cj-start-time + (- (float-time) + (* 10 cj/recording-start-fail-threshold))) + (process-put proc 'cj-output-file stub) + (cj/recording-process-sentinel proc "finished\n") + (should (file-exists-p stub))) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-boundary-user-stop-keeps-file () + "Boundary: a quick user stop (cj-stopping) never deletes the file." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file))) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + ;; Quick exit, but the user asked for it. + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-stopping t) + (process-put proc 'cj-output-file stub) + (cj/recording-process-sentinel proc "finished\n") + (should (file-exists-p stub))) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-boundary-missing-stub-no-error () + "Boundary: failed start whose stub never hit disk signals no error." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process))) + (setq cj/video-recording-ffmpeg-process proc) + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-output-file "/nonexistent/dir/never-written.mkv") + ;; Must not signal even though the file is absent. + (cj/recording-process-sentinel proc "exited abnormally\n") + (should (null cj/video-recording-ffmpeg-process))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-error-nil-output-property-no-error () + "Error: failed start with no cj-output-file property signals no error. +Covers processes started before the property existed (a live daemon +mid-upgrade) — the sentinel degrades to the old message-only path." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process))) + (setq cj/video-recording-ffmpeg-process proc) + (process-put proc 'cj-start-time (float-time)) + ;; No cj-output-file property at all. + (cj/recording-process-sentinel proc "exited abnormally\n") + (should (null cj/video-recording-ffmpeg-process))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-start-stamps-output-file () + "Normal: `cj/ffmpeg-record-video' stamps cj-output-file on the process." + (test-sentinel-setup) + (unwind-protect + (let ((cj/recording-mic-device "test-mic-device") + (cj/recording-system-device "test-monitor-device") + (cj/recording-mic-boost 2.0) + (cj/recording-system-volume 1.0)) + (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) + ((symbol-function 'cj/recording--validate-system-audio) + (lambda () nil)) + ((symbol-function 'start-process-shell-command) + (lambda (_name _buffer _command) + (make-process :name "fake-video" :command '("sleep" "1000"))))) + (cj/ffmpeg-record-video "/tmp/video-recordings/") + (let ((output-file (process-get cj/video-recording-ffmpeg-process + 'cj-output-file))) + (should (stringp output-file)) + (should (string-suffix-p ".mkv" output-file)) + (should (string-prefix-p "/tmp/video-recordings/" output-file)))) + (when cj/video-recording-ffmpeg-process + (ignore-errors (delete-process cj/video-recording-ffmpeg-process)))) + (test-sentinel-teardown))) + (provide 'test-video-audio-recording-process-sentinel) ;;; test-video-audio-recording-process-sentinel.el ends here diff --git a/tests/test-wrap-up--bury-buffers.el b/tests/test-wrap-up--bury-buffers.el new file mode 100644 index 00000000..00df69c7 --- /dev/null +++ b/tests/test-wrap-up--bury-buffers.el @@ -0,0 +1,96 @@ +;;; test-wrap-up--bury-buffers.el --- Tests for cj/bury-buffers -*- lexical-binding: t; -*- + +;;; Commentary: +;; Characterization tests for cj/bury-buffers, which buries the noisy +;; compile-and-shell buffers at the end of startup. +;; +;; Written to pin the buried set while a dead clause was removed. The function +;; tested `(derived-mode-p 'elisp-compile-mode)', and no such mode exists in +;; Emacs -- the real one is `emacs-lisp-compilation-mode', which derives from +;; `compilation-mode' and so was already matched by the clause above it. The +;; clause could never be true, and removing it must not change which buffers +;; get buried. These tests are what makes that claim checkable. +;; +;; Test organization: +;; - Normal Cases: each buried mode is buried; byte-compilation output included +;; - Boundary Cases: an ordinary buffer is left alone; an empty buffer list +;; - Error Cases: a killed buffer in the list does not break the sweep +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'wrap-up) + +;; Required explicitly so each test stands alone. Without these the +;; comint-mode test passed only because ERT runs tests in alphabetical order +;; and an earlier test loaded `compile', which pulls in comint -- so renaming +;; or running that test by itself made it fail with void-function comint-mode. +(require 'comint) +(require 'bytecomp) + +(defmacro test-wrap-up--with-mode-buffer (mode &rest body) + "Create a buffer in MODE, bind it to `buf', run BODY, then kill it." + (declare (indent 1)) + `(let ((buf (generate-new-buffer "*test-bury*"))) + (unwind-protect + (progn + (with-current-buffer buf (funcall ,mode)) + ,@body) + (kill-buffer buf)))) + +;;; Normal Cases + +(ert-deftest test-wrap-up-bury-buffers-buries-compilation () + "Normal: a compilation-mode buffer is buried." + (test-wrap-up--with-mode-buffer #'compilation-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-buries-byte-compilation-output () + "Normal: the real byte-compilation mode is buried. +`emacs-lisp-compilation-mode' derives from `compilation-mode', which is +why the never-matching elisp-compile-mode clause was redundant." + (should (eq 'compilation-mode + (get 'emacs-lisp-compilation-mode 'derived-mode-parent))) + (test-wrap-up--with-mode-buffer #'emacs-lisp-compilation-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-buries-comint () + "Normal: a comint-mode buffer is buried." + (test-wrap-up--with-mode-buffer #'comint-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +;;; Boundary Cases + +(ert-deftest test-wrap-up-bury-buffers-leaves-ordinary-buffer () + "Boundary: a fundamental-mode buffer is not buried." + (test-wrap-up--with-mode-buffer #'fundamental-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-leaves-text-buffer () + "Boundary: an ordinary text-mode buffer is not buried." + (test-wrap-up--with-mode-buffer #'text-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should (eq buf (car (buffer-list)))))) + +;;; Error Cases + +(ert-deftest test-wrap-up-bury-buffers-survives-dead-mode-name () + "Error: the sweep completes even though elisp-compile-mode does not exist. +The removed clause named a mode Emacs has never defined; this pins that +the function still runs cleanly with no such mode anywhere." + (should-not (fboundp 'elisp-compile-mode)) + (should-not (get 'elisp-compile-mode 'derived-mode-parent)) + (cj/bury-buffers)) + +(provide 'test-wrap-up--bury-buffers) +;;; test-wrap-up--bury-buffers.el ends here |