diff options
Diffstat (limited to 'tests')
135 files changed, 7690 insertions, 2088 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--runtime.el b/tests/test-ai-term--runtime.el new file mode 100644 index 00000000..7644e468 --- /dev/null +++ b/tests/test-ai-term--runtime.el @@ -0,0 +1,136 @@ +;;; test-ai-term--runtime.el --- Tests for the ai-term runtime selection -*- lexical-binding: t; -*- + +;;; Commentary: +;; Multi-backend launch: a fresh agent session can run Claude, Codex, or a +;; local model through codex --oss (ollama). The runtime names and launch +;; strings mirror the rulesets bin/ai launcher so the two stay one mental +;; model: "claude", "codex", and "local:<model>". +;; +;; Pure pieces tested here: +;; - `cj/--ai-term-runtime-command' maps a runtime name to the full shell +;; command (agent CLI + the shared opening prompt). +;; - `cj/--ai-term-parse-runtime-lines' parses `ai --print-runtimes' output +;; into (NAME . LABEL) choices. +;; - `cj/--ai-term-runtime-choices' shells out to `ai' at its boundary +;; (mocked here) and falls back to the static list when `ai' is absent. +;; The interactive picker is a thin completing-read wrapper and is not +;; tested (Interactive vs Internal split). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +;;; ------------------------- runtime -> command ------------------------------ + +(ert-deftest test-ai-term-runtime-command-claude-is-agent-command () + "Normal: \"claude\" (and nil) return `cj/ai-term-agent-command' verbatim." + (let ((cj/ai-term-agent-command "claude \"do the thing\"")) + (should (equal (cj/--ai-term-runtime-command "claude") + "claude \"do the thing\"")) + (should (equal (cj/--ai-term-runtime-command nil) + "claude \"do the thing\"")))) + +(ert-deftest test-ai-term-runtime-command-codex-composes-prompt () + "Normal: \"codex\" is the codex CLI plus the shared opening prompt." + (let ((cj/ai-term-agent-prompt "read the protocols")) + (should (equal (cj/--ai-term-runtime-command "codex") + (concat "codex " (shell-quote-argument "read the protocols")))))) + +(ert-deftest test-ai-term-runtime-command-local-model () + "Normal: \"local:<model>\" runs codex --oss against that ollama model. +The model is shell-quoted, and POSIX `shell-quote-argument' backslash-escapes +the colons, so the assertion matches the quoted form." + (let ((cj/ai-term-agent-prompt "read the protocols")) + (let ((cmd (cj/--ai-term-runtime-command "local:gpt-oss:120b"))) + (should (string-prefix-p "codex --oss --local-provider=ollama -m " cmd)) + (should (string-match-p + (regexp-quote (shell-quote-argument "gpt-oss:120b")) cmd)) + (should (string-suffix-p (shell-quote-argument "read the protocols") cmd))))) + +(ert-deftest test-ai-term-runtime-command-boundary-empty-model () + "Boundary: \"local:\" with no model is rejected, not launched half-formed." + (should-error (cj/--ai-term-runtime-command "local:") :type 'user-error)) + +(ert-deftest test-ai-term-runtime-command-error-unknown-runtime () + "Error: an unknown runtime name signals a `user-error' naming it." + (should-error (cj/--ai-term-runtime-command "gemini") :type 'user-error) + (condition-case err + (cj/--ai-term-runtime-command "gemini") + (user-error (should (string-match-p "gemini" (cadr err)))))) + +;;; --------------------------- choice-list parsing --------------------------- + +(ert-deftest test-ai-term-parse-runtime-lines-normal () + "Normal: `ai --print-runtimes' lines parse into (NAME . LABEL) pairs." + (should (equal (cj/--ai-term-parse-runtime-lines + "claude — Claude Code\ncodex — ChatGPT (Codex CLI)\nlocal:gpt-oss:120b — ollama\n") + '(("claude" . "Claude Code") + ("codex" . "ChatGPT (Codex CLI)") + ("local:gpt-oss:120b" . "ollama"))))) + +(ert-deftest test-ai-term-parse-runtime-lines-boundary-junk () + "Boundary: blank lines and lines without a separator are dropped." + (should (equal (cj/--ai-term-parse-runtime-lines + "\nclaude — Claude Code\nwarning: something\n\n") + '(("claude" . "Claude Code"))))) + +(ert-deftest test-ai-term-parse-runtime-lines-boundary-empty () + "Boundary: empty output parses to nil." + (should (null (cj/--ai-term-parse-runtime-lines "")))) + +;;; ------------------------------ choice list -------------------------------- + +(ert-deftest test-ai-term-runtime-choices-uses-ai-launcher () + "Normal: when the `ai' launcher exists, its runtime list is the choice list." + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "ai") "/usr/bin/ai"))) + ((symbol-function 'process-file) + (lambda (_prog _infile buffer _display &rest _args) + (with-current-buffer (cond ((eq buffer t) (current-buffer)) + ((consp buffer) (car buffer)) + (t buffer)) + (insert "claude — Claude Code\nlocal:q — ollama\n")) + 0))) + (should (equal (cj/--ai-term-runtime-choices) + '(("claude" . "Claude Code") ("local:q" . "ollama")))))) + +(ert-deftest test-ai-term-runtime-choices-fallback-without-ai () + "Boundary: with no `ai' launcher, the static claude-first list stands." + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil))) + (let ((choices (cj/--ai-term-runtime-choices))) + (should (equal (caar choices) "claude")) + (should (assoc "codex" choices))))) + +(ert-deftest test-ai-term-runtime-choices-error-ai-fails () + "Error: a nonzero exit from `ai' falls back instead of erroring." + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "ai") "/usr/bin/ai"))) + ((symbol-function 'process-file) (lambda (&rest _) 1))) + (should (equal (caar (cj/--ai-term-runtime-choices)) "claude")))) + +;;; --------------------- launch command takes an override -------------------- + +(ert-deftest test-ai-term-launch-command-runtime-override () + "Normal: an explicit agent command is embedded instead of the default. +The inner command is shell-quoted by the launch builder, so the assertion +matches the quoted form." + (let ((cj/ai-term-agent-command "claude default")) + (let ((cmd (cj/--ai-term-launch-command "/tmp/proj" "codex prompted"))) + (should (string-match-p + (regexp-quote (shell-quote-argument "codex prompted; exec bash")) + cmd)) + (should-not (string-match-p "claude" cmd))))) + +(ert-deftest test-ai-term-launch-command-no-override-falls-back () + "Boundary: without an override the configured agent command is used." + (let ((cj/ai-term-agent-command "claude default")) + (should (string-match-p + (regexp-quote (shell-quote-argument "claude default; exec bash")) + (cj/--ai-term-launch-command "/tmp/proj"))))) + +(provide 'test-ai-term--runtime) +;;; test-ai-term--runtime.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 2686b88f..12435fa0 100644 --- a/tests/test-auto-dim-config.el +++ b/tests/test-auto-dim-config.el @@ -35,6 +35,210 @@ (when (fboundp 'auto-dim-other-buffers-mode) (auto-dim-other-buffers-mode -1)))) +(defconst test-auto-dim--flat-dimmed-org-faces + (append (mapcar (lambda (n) (intern (format "org-level-%d" n))) + (number-sequence 1 8)) + '(org-link org-tag + ;; Document header: #+TITLE:, #+AUTHOR:, #+ARCHIVE: and their values. + org-document-title org-document-info org-document-info-keyword + org-meta-line + ;; Inline markup and blocks. + org-code org-verbatim org-block-begin-line org-block-end-line + ;; Drawers, properties, planning lines. + org-drawer org-special-keyword org-property-value org-date + ;; Tables and the fold indicator. + org-table org-table-row org-ellipsis)) + "Org faces that must flat-dim to the `auto-dim-other-buffers' face. +These carry structure, not status: nothing about them needs to stay +readable in a window the user is not looking at. Excluded on purpose are +`org-todo' and `org-priority' (keyword class -- see the -dim variant test +below) and `org-hide' (needs `auto-dim-other-buffers-hide' so folded text +stays hidden).") + +(defconst test-auto-dim--flat-dimmed-link-faces + '(link link-visited) + "Built-in link faces that must flat-dim, distinct from `org-link'. +They fontify links in help, info, and customize buffers. Both carry +`:underline t', which survives the relative remap, so a dimmed link still +reads as a link.") + +(defconst test-auto-dim--flat-dimmed-superstar-faces + '(org-superstar-header-bullet org-superstar-item org-superstar-first) + "org-superstar faces that must flat-dim. +org-superstar puts its own face ahead of the org face beneath, so a heading +star renders as (org-superstar-header-bullet org-level-1) and wins over the +dimmed org-level-1. Without these, bullets stay lit in an unfocused window +even though every face under them dims. +`org-superstar-leading' is excluded on purpose -- see the test below.") + +(defconst test-auto-dim--hide-class-faces + '(org-hide org-superstar-leading org-indent) + "Faces whose foreground IS the background colour. +That is what makes them invisible. They take `auto-dim-other-buffers-hide', +never the flat dim, which would paint them visible grey.") + +(defconst test-auto-dim--no-foreground-faces + '(bold italic underline) + "Faces that carry no foreground, even through inheritance. +They set weight, slant or underline only, so text wearing them takes its +colour from `default', which is already remapped. They need no entry and +must not gain one, or the alist grows entries that do nothing.") + +(defconst test-auto-dim--keyword-dim-variants + '((org-faces-todo . org-faces-todo-dim) + (org-faces-doing . org-faces-doing-dim) + (org-faces-priority-a . org-faces-priority-a-dim)) + "Sample of keyword faces that must keep dedicated -dim variants.") + +(ert-deftest test-auto-dim-config-org-structure-faces-flat-dim () + "Normal: org heading, link, and tag faces remap to the flat dim face." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--flat-dimmed-org-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers (car (cdr entry)))) + (should (null (cdr (cdr entry))))))) + +(ert-deftest test-auto-dim-config-link-faces-flat-dim () + "Normal: the built-in `link' and `link-visited' faces flat-dim. +Without these, links in help, info, and customize buffers stay lit while +the rest of an unfocused window fades. `org-link' is a separate face and +is covered above." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--flat-dimmed-link-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers (car (cdr entry)))) + (should (null (cdr (cdr entry))))))) + +(ert-deftest test-auto-dim-config-link-underline-survives-the-remap () + "Boundary: the dim face sets no `:underline', so the link cue survives. +A relative remap layers the dim face over the base face, so an underline +the dim face does not specify falls through from `link'. If the theme ever +gives `auto-dim-other-buffers' an `:underline', dimmed links stop looking +like links and this test says so." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (should (eq 'unspecified + (face-attribute 'auto-dim-other-buffers :underline nil nil)))) + +(ert-deftest test-auto-dim-config-superstar-bullets-flat-dim () + "Normal: org-superstar's heading stars and list bullets flat-dim. +They were the last thing left lit in an unfocused org window." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--flat-dimmed-superstar-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers (car (cdr entry)))) + (should (null (cdr (cdr entry))))))) + +(ert-deftest test-auto-dim-config-superstar-leading-uses-hide-face () + "Error: `org-superstar-leading' takes the -hide face, never the flat dim. +Its foreground is the background colour, which is what keeps hidden leading +stars invisible. Flat-dimming it would give them the dim face's visible grey +and reveal stars the user chose to hide. Same contract as `org-hide'." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (should-not (memq 'org-superstar-leading + test-auto-dim--flat-dimmed-superstar-faces)) + (let ((entry (assq 'org-superstar-leading auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers-hide (car (cdr entry)))))) + +(ert-deftest test-auto-dim-config-hide-class-faces-use-hide-face () + "Error: every background-coloured face takes the -hide face. +`org-hide', `org-superstar-leading' and `org-indent' all resolve to the +background colour, which is what keeps folded text, leading stars and indent +prefixes invisible. Flat-dimming any of them reveals what the user hid." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--hide-class-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers-hide (car (cdr entry))))))) + +(ert-deftest test-auto-dim-config-no-org-face-left-unmapped () + "Boundary: a fontified org buffer uses no face we forgot to handle. +Four rounds of this bug all had the same shape: a face nobody enumerated, +sitting ahead of a mapped face in a face list and outranking it. This walks +a representative buffer, collects every face it actually uses (including the +`line-prefix' and `wrap-prefix' org-indent hangs its faces on), and fails on +anything that is neither mapped nor deliberately excluded. + +Built-in org only. org-superstar and org-drill are elpa packages, and the +test run has no `package-initialize', so their faces are pinned by name in +the tests above instead." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (require 'org) + (let ((used (make-hash-table :test #'eq)) + (allowed (append test-auto-dim--no-foreground-faces + ;; Keyword class: deliberately unmapped so status stays + ;; readable in an unfocused window. Pinned by + ;; test-auto-dim-config-todo-priority-faces-not-flat-dimmed. + '(org-todo org-priority) + (mapcar #'car auto-dim-other-buffers-affected-faces)))) + (with-temp-buffer + (insert "#+TITLE: T\n#+AUTHOR: A\n\n* H1 :tag:\n** TODO [#A] task\n" + "DEADLINE: <2026-07-10 Fri>\n:PROPERTIES:\n:K: v\n:END:\n" + "Body ~verbatim~ =code= [[https://x.org][link]].\n" + "| a | b |\n|---+---|\n| 1 | 2 |\n" + "#+begin_src sh\necho hi\n#+end_src\n" + "- [X] done item\n") + (org-mode) + (font-lock-ensure) + (let ((p (point-min))) + (while (< p (point-max)) + (dolist (f (let ((v (get-text-property p 'face))) + (if (listp v) v (list v)))) + (when (and f (symbolp f)) (puthash f t used))) + (dolist (prop '(line-prefix wrap-prefix)) + (let ((s (get-text-property p prop))) + (when (stringp s) + (dolist (f (let ((v (get-text-property 0 'face s))) + (if (listp v) v (list v)))) + (when (and f (symbolp f)) (puthash f t used)))))) + (setq p (1+ p))))) + (let (unmapped) + (maphash (lambda (face _v) + (unless (memq face allowed) (push face unmapped))) + used) + (should (equal nil (sort unmapped #'string<)))))) + +(ert-deftest test-auto-dim-config-keyword-faces-keep-dim-variants () + "Boundary: org TODO-keyword faces keep dedicated -dim variants, not flat dim. +Keyword status is scanned across unfocused windows, so it earns a variant; +heading colour does not. Guards the flat-dim change from over-reaching." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (pair test-auto-dim--keyword-dim-variants) + (let ((entry (assq (car pair) auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq (cdr pair) (car (cdr entry))))))) + +(ert-deftest test-auto-dim-config-todo-priority-faces-not-flat-dimmed () + "Boundary: `org-todo' and `org-priority' are never flat-dimmed. +They are keyword class. Dimming them would erase the status colour the +-dim variants exist to preserve, so they stay out of the flat-dim set." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face '(org-todo org-priority)) + (should-not (memq face test-auto-dim--flat-dimmed-org-faces)) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should-not (and entry (eq 'auto-dim-other-buffers (car (cdr entry)))))))) + +(ert-deftest test-auto-dim-config-org-hide-uses-hide-face () + "Boundary: `org-hide' remaps to the -hide face, not the flat dim face. +Flat-dimming it would give folded text a visible foreground." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (let ((entry (assq 'org-hide auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers-hide (car (cdr entry)))))) + (ert-deftest test-auto-dim-config-never-dim-dashboard-exempts-dashboard () "Normal: the *dashboard* buffer is exempt from dimming." (skip-unless (file-directory-p test-auto-dim--fork)) 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..d2d25a70 100644 --- a/tests/test-calendar-sync--expand-monthly.el +++ b/tests/test-calendar-sync--expand-monthly.el @@ -170,5 +170,104 @@ (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)))))) + (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--get-exdates.el b/tests/test-calendar-sync--get-exdates.el index 3283bbae..981a1857 100644 --- a/tests/test-calendar-sync--get-exdates.el +++ b/tests/test-calendar-sync--get-exdates.el @@ -103,6 +103,35 @@ END:VEVENT")) (should (= 1 (length result))) (should (string= "20260210T130000" (car result)))))) +(ert-deftest test-calendar-sync--get-exdates-boundary-comma-separated-returns-all () + "Boundary: comma-separated EXDATE values on one line are each returned. +RFC 5545 permits multiple datetimes per EXDATE line; missing the split +drops those exclusions, so cancelled instances resurrect in the agenda." + (let ((event "BEGIN:VEVENT +DTSTART:20260203T130000 +RRULE:FREQ=WEEKLY;BYDAY=TU +EXDATE:20260210T130000,20260217T130000,20260224T130000 +SUMMARY:Weekly Meeting +END:VEVENT")) + (let ((result (calendar-sync--get-exdates event))) + (should (= 3 (length result))) + (should (member "20260210T130000" result)) + (should (member "20260217T130000" result)) + (should (member "20260224T130000" result))))) + +(ert-deftest test-calendar-sync--get-exdates-boundary-comma-separated-with-tzid () + "Boundary: comma-separated EXDATE values sharing a TZID are each returned." + (let ((event "BEGIN:VEVENT +DTSTART;TZID=America/New_York:20260203T130000 +RRULE:FREQ=WEEKLY;BYDAY=TU +EXDATE;TZID=America/New_York:20260210T130000,20260217T130000 +SUMMARY:Weekly Meeting +END:VEVENT")) + (let ((result (calendar-sync--get-exdates event))) + (should (= 2 (length result))) + (should (member "20260210T130000" result)) + (should (member "20260217T130000" result))))) + ;;; Error Cases (ert-deftest test-calendar-sync--get-exdates-error-empty-string-returns-nil () 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-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-source-fetch-sentinel.el b/tests/test-calendar-sync-source-fetch-sentinel.el new file mode 100644 index 00000000..0b7ba1cf --- /dev/null +++ b/tests/test-calendar-sync-source-fetch-sentinel.el @@ -0,0 +1,72 @@ +;;; test-calendar-sync-source-fetch-sentinel.el --- Tests for the fetch sentinel -*- lexical-binding: t; -*- + +;;; Commentary: +;; calendar-sync--fetch-sentinel-finish is the extracted tail of the async +;; .ics fetch sentinel. The async-worker tests stub the whole fetch, so its +;; success, failure, and temp-file-cleanup branches were never exercised. +;; These tests drive the helper directly with fake success/failure inputs, +;; no live curl process. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'calendar-sync) + +(ert-deftest test-calendar-sync-fetch-sentinel-success-passes-temp-file () + "Normal: on success the callback gets the temp file and it is not deleted." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (buffer (generate-new-buffer " *cs-test*")) + (got 'unset)) + (unwind-protect + (progn + (calendar-sync--fetch-sentinel-finish + t "finished\n" temp-file buffer (lambda (r) (setq got r))) + (should (equal got temp-file)) + (should (file-exists-p temp-file)) + (should-not (buffer-live-p buffer))) + (when (file-exists-p temp-file) (delete-file temp-file)) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest test-calendar-sync-fetch-sentinel-failure-deletes-and-passes-nil () + "Error: on failure the temp file is deleted and the callback gets nil." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (buffer (generate-new-buffer " *cs-test*")) + (got 'unset) + (logged nil)) + (unwind-protect + (cl-letf (((symbol-function 'calendar-sync--log-silently) + (lambda (&rest _) (setq logged t)))) + (calendar-sync--fetch-sentinel-finish + nil "exited abnormally with code 22\n" temp-file buffer + (lambda (r) (setq got r))) + (should (null got)) + (should-not (file-exists-p temp-file)) + (should logged) + (should-not (buffer-live-p buffer))) + (when (file-exists-p temp-file) (delete-file temp-file)) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest test-calendar-sync-fetch-sentinel-failure-tolerates-missing-temp-file () + "Boundary: failure with the temp file already gone does not error." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (got 'unset)) + (delete-file temp-file) + (cl-letf (((symbol-function 'calendar-sync--log-silently) #'ignore)) + (calendar-sync--fetch-sentinel-finish + nil "failed\n" temp-file nil (lambda (r) (setq got r))) + (should (null got))))) + +(ert-deftest test-calendar-sync-fetch-sentinel-tolerates-dead-buffer () + "Boundary: a already-dead process buffer is not touched on success." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (got 'unset)) + (unwind-protect + (progn + (calendar-sync--fetch-sentinel-finish + t "finished\n" temp-file nil (lambda (r) (setq got r))) + (should (equal got temp-file))) + (when (file-exists-p temp-file) (delete-file temp-file))))) + +(provide 'test-calendar-sync-source-fetch-sentinel) +;;; test-calendar-sync-source-fetch-sentinel.el ends here diff --git a/tests/test-config-utilities--recompile-emacs-home.el b/tests/test-config-utilities--recompile-emacs-home.el index 18d17f96..da364e24 100644 --- a/tests/test-config-utilities--recompile-emacs-home.el +++ b/tests/test-config-utilities--recompile-emacs-home.el @@ -81,20 +81,29 @@ Returns the temp dir path." (should-not (file-exists-p (expand-file-name "sub/c.elc" dir)))) (delete-directory dir t)))) -(ert-deftest test-config-utilities-recompile-removes-eln-dir-on-native-path () - "Boundary: the native path removes the eln cache directory when present." +(ert-deftest test-config-utilities-recompile-removes-eln-cache-dir-on-native-path () + "Boundary: the native path removes the eln-cache directory when present. +The native cache is eln-cache/, not eln/, so that is the directory to clear." (let ((dir (test-config-utilities--make-recompile-fixture)) - (eln-dir nil)) + (eln-cache-dir nil)) (unwind-protect (progn - (setq eln-dir (expand-file-name "eln" dir)) - (make-directory eln-dir) - (with-temp-file (expand-file-name "stale.eln" eln-dir) (insert "")) + (setq eln-cache-dir (expand-file-name "eln-cache" dir)) + (make-directory eln-cache-dir) + (with-temp-file (expand-file-name "stale.eln" eln-cache-dir) (insert "")) (cl-letf (((symbol-function 'native-compile-async) (lambda (&rest _) nil))) (cj/--recompile-emacs-home dir t)) - (should-not (file-exists-p eln-dir))) + (should-not (file-exists-p eln-cache-dir))) (delete-directory dir t)))) +(ert-deftest test-config-utilities-native-comp-detection-not-boundp () + "Regression: native-comp detection must not test `boundp' of the async +function -- native-compile-async is a function, so `boundp' is always nil and +native compilation would never be selected. On a native-comp build, detection +returns non-nil." + (when (and (fboundp 'native-comp-available-p) (native-comp-available-p)) + (should (cj/--native-comp-p)))) + (ert-deftest test-config-utilities-recompile-removes-elc-dir-on-byte-path () "Boundary: the byte path removes the elc cache directory when present." (let ((dir (test-config-utilities--make-recompile-fixture)) diff --git a/tests/test-custom-buffer-file--view-email-in-buffer.el b/tests/test-custom-buffer-file--view-email-in-buffer.el index 99e0e44d..b0209b78 100644 --- a/tests/test-custom-buffer-file--view-email-in-buffer.el +++ b/tests/test-custom-buffer-file--view-email-in-buffer.el @@ -13,6 +13,7 @@ ;;; Code: (require 'ert) +(require 'cl-lib) (require 'testutil-general) (require 'custom-buffer-file) @@ -233,5 +234,24 @@ Note: shr may insert newlines between words for wrapping." (kill-buffer))) (test-email--teardown))) +(ert-deftest test-custom-buffer-file--view-email-no-displayable-destroys-handle () + "Error: the MIME handle is destroyed even when no displayable part is found. +The `user-error' fires before cleanup, so without `unwind-protect' the dissected +handle leaks." + (test-email--setup) + (unwind-protect + (let ((eml-file (test-email--create-eml-file test-email--image-only)) + (destroy-called nil)) + (with-current-buffer (find-file-noselect eml-file) + (let ((real (symbol-function 'mm-destroy-parts))) + (cl-letf (((symbol-function 'mm-destroy-parts) + (lambda (handle) + (setq destroy-called t) + (funcall real handle)))) + (should-error (cj/view-email-in-buffer) :type 'user-error))) + (should destroy-called) + (kill-buffer))) + (test-email--teardown))) + (provide 'test-custom-buffer-file--view-email-in-buffer) ;;; test-custom-buffer-file--view-email-in-buffer.el ends here diff --git a/tests/test-custom-buffer-file-copy-link-to-buffer-file.el b/tests/test-custom-buffer-file-copy-link-to-buffer-file.el index 262968d6..5ee57b3a 100644 --- a/tests/test-custom-buffer-file-copy-link-to-buffer-file.el +++ b/tests/test-custom-buffer-file-copy-link-to-buffer-file.el @@ -4,7 +4,8 @@ ;; Tests for the cj/copy-link-to-buffer-file function from custom-buffer-file.el ;; ;; This function copies the full file:// path of the current buffer's file to -;; the kill ring. For non-file buffers, it does nothing (no error). +;; the kill ring. For non-file buffers, it signals a user-error, matching its +;; sibling copy commands. ;;; Code: @@ -58,12 +59,12 @@ (test-copy-link-teardown))) (ert-deftest test-copy-link-non-file-buffer () - "Should do nothing for non-file buffer without error." + "Error: a non-file buffer signals `user-error' and leaves the kill ring alone." (test-copy-link-setup) (unwind-protect (with-temp-buffer (setq kill-ring nil) - (cj/copy-link-to-buffer-file) + (should-error (cj/copy-link-to-buffer-file) :type 'user-error) (should (null kill-ring))) (test-copy-link-teardown))) @@ -195,13 +196,13 @@ (test-copy-link-teardown))) (ert-deftest test-copy-link-scratch-buffer () - "Should do nothing for *scratch* buffer." + "Error: the *scratch* buffer (no file) signals `user-error'." (test-copy-link-setup) (unwind-protect (progn (setq kill-ring nil) (with-current-buffer "*scratch*" - (cj/copy-link-to-buffer-file) + (should-error (cj/copy-link-to-buffer-file) :type 'user-error) (should (null kill-ring)))) (test-copy-link-teardown))) diff --git a/tests/test-custom-case-title-case-region.el b/tests/test-custom-case-title-case-region.el index 383ae927..82b4966a 100644 --- a/tests/test-custom-case-title-case-region.el +++ b/tests/test-custom-case-title-case-region.el @@ -60,16 +60,17 @@ an active region, and return the result." "The Art of War"))) (ert-deftest test-custom-case-title-case-region-normal-all-minor-words () - "All minor words in the skip list should be lowercased in mid-sentence." + "All minor words in the skip list should be lowercased in mid-sentence. +\"is\" is a linking verb, so it is a major word and is capitalized." (should (equal (test-title-case--on-string "go a an and as at but by for if in is nor of on or so the to yet go") - "Go a an and as at but by for if in is nor of on or so the to yet Go"))) + "Go a an and as at but by for if in Is nor of on or so the to yet Go"))) (ert-deftest test-custom-case-title-case-region-normal-four-letter-words-capitalized () "Words of four or more letters should always be capitalized. -Note: 'is' is explicitly in the minor word list, so it stays lowercase." +\"is\" is a linking verb (a major word), so it is capitalized too." (should (equal (test-title-case--on-string "this is from that with over") - "This is From That With Over"))) + "This Is From That With Over"))) (ert-deftest test-custom-case-title-case-region-normal-allcaps-input () "All-caps input should be downcased first, then title-cased." @@ -94,7 +95,16 @@ Note: 'is' is explicitly in the minor word list, so it stays lowercase." (ert-deftest test-custom-case-title-case-region-normal-question-resets () "Word immediately after a question mark should be capitalized, even if minor." (should (equal (test-title-case--on-string "really? the answer is no") - "Really? The Answer is No"))) + "Really? The Answer Is No"))) + +(ert-deftest test-custom-case-title-case-region-normal-last-word-capitalized () + "The last word is always capitalized, even a minor one." + (should (equal (test-title-case--on-string "the art of") "The Art Of"))) + +(ert-deftest test-custom-case-title-case-region-normal-period-restarts () + "A word after a sentence-ending period should be capitalized." + (should (equal (test-title-case--on-string "one. the next sentence") + "One. The Next Sentence"))) (ert-deftest test-custom-case-title-case-region-normal-hyphenated-word () "Second part of a hyphenated word should NOT be capitalized." @@ -141,7 +151,7 @@ Note: 'is' is explicitly in the minor word list, so it stays lowercase." (ert-deftest test-custom-case-title-case-region-boundary-unicode-words () "Unicode characters should pass through without error." (should (equal (test-title-case--on-string "the café is nice") - "The Café is Nice"))) + "The Café Is Nice"))) (ert-deftest test-custom-case-title-case-region-boundary-numbers-in-text () "Numbers mixed with text should not break title casing." diff --git a/tests/test-custom-comments-comment-inline-border.el b/tests/test-custom-comments-comment-inline-border.el index 78e86035..305a2c7a 100644 --- a/tests/test-custom-comments-comment-inline-border.el +++ b/tests/test-custom-comments-comment-inline-border.el @@ -120,6 +120,16 @@ Returns the buffer string for assertions." (let ((result (test-inline-border-at-column 0 ";;" "" "=" "" 10))) (should (string-match-p ";" result)))) +(ert-deftest test-inline-border-elisp-fills-exact-width-all-parities () + "Boundary: even, odd, and empty text all fill LENGTH exactly. +Even-length and empty text used to come out two columns short because the +right decoration count keyed off text-length parity instead of the remaining +width, so stacked dividers of differing text lengths misaligned." + (dolist (text '("" "X" "EVEN" "ODD" "Header")) + (let* ((result (test-inline-border-at-column 0 ";;" "" "=" text 50)) + (line (string-trim-right result "\n"))) + (should (= 50 (length line)))))) + (ert-deftest test-inline-border-elisp-text-centering-even () "Should center text properly with even length." (let ((result (test-inline-border-at-column 0 ";;" "" "=" "EVEN" 70))) diff --git a/tests/test-custom-comments-comment-reformat.el b/tests/test-custom-comments-comment-reformat.el index 83248aee..91b7dfe3 100644 --- a/tests/test-custom-comments-comment-reformat.el +++ b/tests/test-custom-comments-comment-reformat.el @@ -146,19 +146,12 @@ Insert CONTENT-BEFORE, select all, run cj/comment-reformat, verify EXPECTED-AFTE (should (string-match-p ";; Start line 1.*Start line 2" (buffer-string))))) (ert-deftest test-comment-reformat-elisp-no-region-active () - "Should show message when no region selected." + "Should signal `user-error' when no region is selected." (with-temp-buffer (emacs-lisp-mode) (insert ";; Comment line") (deactivate-mark) - (let ((message-log-max nil) - (messages '())) - ;; Capture messages - (cl-letf (((symbol-function 'message) - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) - (cj/comment-reformat) - (should (string-match-p "No region was selected" (car messages))))))) + (should-error (cj/comment-reformat) :type 'user-error))) (ert-deftest test-comment-reformat-elisp-read-only-buffer () "Should signal error in read-only buffer." diff --git a/tests/test-custom-datetime-all-methods.el b/tests/test-custom-datetime-all-methods.el index 62b421bd..1f31c6c4 100644 --- a/tests/test-custom-datetime-all-methods.el +++ b/tests/test-custom-datetime-all-methods.el @@ -54,9 +54,10 @@ (should (string-match-p "14:30:45" result)))) (ert-deftest test-custom-datetime-all-methods-normal-sortable-time () - "cj/insert-sortable-time should insert time with AM/PM and timezone." + "cj/insert-sortable-time should insert 24-hour time so it sorts lexically." (let ((result (test-datetime--run #'cj/insert-sortable-time))) - (should (string-match-p "02:30:45 PM" result)))) + (should (string-match-p "14:30:45" result)) + (should-not (string-match-p "PM" result)))) (ert-deftest test-custom-datetime-all-methods-normal-readable-time () "cj/insert-readable-time should insert short time with AM/PM." diff --git a/tests/test-custom-line-paragraph-duplicate-line-or-region.el b/tests/test-custom-line-paragraph-duplicate-line-or-region.el index 84f5bc2d..9e501086 100644 --- a/tests/test-custom-line-paragraph-duplicate-line-or-region.el +++ b/tests/test-custom-line-paragraph-duplicate-line-or-region.el @@ -327,6 +327,40 @@ (should (> (length (buffer-string)) (length "line one\nline two\nline three")))) (test-duplicate-line-or-region-teardown))) +(ert-deftest test-duplicate-line-or-region-mid-line-bounds-duplicate-whole-lines () + "A region ending mid-line duplicates every whole line it touches, no splits. +The old open-line loop split the mid-line-ending line instead." + (test-duplicate-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (insert "aaa\nbbb\nccc") + (transient-mark-mode 1) + (goto-char (point-min)) + (forward-char 1) ; mid first line + (set-mark (point)) + (forward-line 1) + (forward-char 2) ; mid second line + (activate-mark) + (cj/duplicate-line-or-region) + (should (string= "aaa\nbbb\naaa\nbbb\nccc" (buffer-string)))) + (test-duplicate-line-or-region-teardown))) + +(ert-deftest test-duplicate-line-or-region-ends-at-bol-no-extra-empty-line () + "A region ending at beginning-of-line duplicates only the fully-included lines. +The old open-line loop duplicated a stray empty line here." + (test-duplicate-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (insert "aaa\nbbb\nccc") + (transient-mark-mode 1) + (goto-char (point-min)) + (set-mark (point)) + (forward-line 2) ; region "aaa\nbbb\n", ends at bol of ccc + (activate-mark) + (cj/duplicate-line-or-region) + (should (string= "aaa\nbbb\naaa\nbbb\nccc" (buffer-string)))) + (test-duplicate-line-or-region-teardown))) + (ert-deftest test-duplicate-line-or-region-trailing-whitespace () "Should preserve trailing whitespace." (test-duplicate-line-or-region-setup) diff --git a/tests/test-custom-line-paragraph-join-line-or-region.el b/tests/test-custom-line-paragraph-join-line-or-region.el index f8738910..5d421683 100644 --- a/tests/test-custom-line-paragraph-join-line-or-region.el +++ b/tests/test-custom-line-paragraph-join-line-or-region.el @@ -62,8 +62,8 @@ (should (string-match-p "line one line two" (buffer-string)))) (test-join-line-or-region-teardown))) -(ert-deftest test-join-line-or-region-no-region-adds-newline-after-join () - "Without region, should add newline after joining." +(ert-deftest test-join-line-or-region-no-region-adds-newline-at-end-of-buffer () + "Without region, joining the last line adds a trailing newline at end of buffer." (test-join-line-or-region-setup) (unwind-protect (with-temp-buffer @@ -73,6 +73,20 @@ (should (string-suffix-p "\n" (buffer-string)))) (test-join-line-or-region-teardown))) +(ert-deftest test-join-line-or-region-no-region-mid-buffer-no-blank-line () + "Without region, joining a non-last line must not insert a blank line. +The trailing newline belongs only at end of buffer; adding it unconditionally +left a stray blank line between the joined line and the rest of the buffer." + (test-join-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (insert "line one\nline two\nline three") + (goto-char (point-min)) + (forward-line 1) ; point on "line two", not the last line + (cj/join-line-or-region) + (should (string= "line one line two\nline three" (buffer-string)))) + (test-join-line-or-region-teardown))) + (ert-deftest test-join-line-or-region-with-region-joins-all-lines () "With region, should join all lines in region." (test-join-line-or-region-setup) diff --git a/tests/test-custom-line-paragraph-jump-to-matching-paren.el b/tests/test-custom-line-paragraph-jump-to-matching-paren.el index 31853da6..bd24faed 100644 --- a/tests/test-custom-line-paragraph-jump-to-matching-paren.el +++ b/tests/test-custom-line-paragraph-jump-to-matching-paren.el @@ -83,11 +83,11 @@ POINT-POSITION is 1-indexed (1 = first character)." ;;; Normal Cases - Backward Jump (Closing to Opening) (ert-deftest test-jump-paren-backward-simple () - "Should jump backward from closing paren to opening paren." + "Should jump from a closing paren to its matching opening paren." ;; Text: "(hello)" ;; Start at position 7 (on closing paren) - ;; Should end at position 2 (after opening paren) - (should (= 2 (test-jump-to-matching-paren "(hello)" 7)))) + ;; Should end at position 1 (the matching opening paren) + (should (= 1 (test-jump-to-matching-paren "(hello)" 7)))) (ert-deftest test-jump-paren-backward-nested () "Should jump backward over nested parens from after outer closing." @@ -97,11 +97,11 @@ POINT-POSITION is 1-indexed (1 = first character)." (should (= 1 (test-jump-to-matching-paren "(foo (bar))" 12)))) (ert-deftest test-jump-paren-backward-inner-nested () - "Should jump backward from inner closing paren." + "Should jump from an inner closing paren to its matching inner opener." ;; Text: "(foo (bar))" ;; Start at position 10 (on inner closing paren) - ;; Should end at position 7 (after inner opening paren) - (should (= 7 (test-jump-to-matching-paren "(foo (bar))" 10)))) + ;; Should end at position 6 (the matching inner opening paren) + (should (= 6 (test-jump-to-matching-paren "(foo (bar))" 10)))) (ert-deftest test-jump-bracket-backward () "Should jump backward from after closing bracket." @@ -145,11 +145,11 @@ POINT-POSITION is 1-indexed (1 = first character)." (should (= 1 (test-jump-to-matching-paren "(hello" 1)))) (ert-deftest test-jump-paren-unmatched-closing () - "Should move to beginning from unmatched closing paren." + "Should stay put on an unmatched closing paren (no matching opener)." ;; Text: "hello)" ;; Start at position 6 (on closing paren with no opening) - ;; backward-sexp with unmatched closing paren goes to beginning - (should (= 1 (test-jump-to-matching-paren "hello)" 6)))) + ;; There is no matching opener, so point is restored and stays at 6 + (should (= 6 (test-jump-to-matching-paren "hello)" 6)))) ;;; Boundary Cases - Empty Delimiters @@ -161,11 +161,11 @@ POINT-POSITION is 1-indexed (1 = first character)." (should (= 3 (test-jump-to-matching-paren "()" 1)))) (ert-deftest test-jump-paren-empty-backward () - "Should stay put when on closing paren of empty parens." + "Should jump from the closing paren of empty parens to its opener." ;; Text: "()" ;; Start at position 2 (on closing paren) - ;; backward-sexp from closing of empty parens gives an error, so stays at 2 - (should (= 2 (test-jump-to-matching-paren "()" 2)))) + ;; Should end at position 1 (the matching opening paren) + (should (= 1 (test-jump-to-matching-paren "()" 2)))) ;;; Boundary Cases - Multiple Delimiter Types diff --git a/tests/test-custom-ordering-number-lines.el b/tests/test-custom-ordering-number-lines.el index adda84f0..142e5561 100644 --- a/tests/test-custom-ordering-number-lines.el +++ b/tests/test-custom-ordering-number-lines.el @@ -122,9 +122,10 @@ Returns the transformed string." (should (string= result "1. ")))) (ert-deftest test-number-lines-empty-lines () - "Should number empty lines." + "Should number empty lines, treating the final newline as a terminator. +The old split counted the trailing newline as a spurious third line." (let ((result (test-number-lines "\n\n" "N. " nil))) - (should (string= result "1. \n2. \n3. ")))) + (should (string= result "1. \n2. \n")))) (ert-deftest test-number-lines-with-existing-numbers () "Should number lines that already have content." diff --git a/tests/test-custom-ordering-reverse-lines.el b/tests/test-custom-ordering-reverse-lines.el index 3c71362d..5b8c01ac 100644 --- a/tests/test-custom-ordering-reverse-lines.el +++ b/tests/test-custom-ordering-reverse-lines.el @@ -86,9 +86,11 @@ Returns the transformed string." (should (string= result "b\n\na")))) (ert-deftest test-reverse-lines-trailing-newline () - "Should handle trailing newline." + "Should reverse the lines and preserve the trailing newline. +The old split dropped the trailing newline into a leading empty line, +producing \"\\nline2\\nline1\"." (let ((result (test-reverse-lines "line1\nline2\n"))) - (should (string= result "\nline2\nline1")))) + (should (string= result "line2\nline1\n")))) (ert-deftest test-reverse-lines-only-newlines () "Should reverse lines that are only newlines." diff --git a/tests/test-custom-text-enclose-indent.el b/tests/test-custom-text-enclose-indent.el index e9042d35..f37d1800 100644 --- a/tests/test-custom-text-enclose-indent.el +++ b/tests/test-custom-text-enclose-indent.el @@ -43,6 +43,35 @@ Returns the transformed string." Returns the transformed string." (cj/--dedent-lines text count)) +;;; Interactive default resolution (the prefix-arg decoupling fix) + +(ert-deftest test-indent-lines-interactive-no-prefix-is-four-spaces () + "Interactive: no prefix indents by 4, spaces when `indent-tabs-mode' is nil. +The old \"p\\nP\" spec defaulted count to 1 and forced tabs on any prefix." + (with-temp-buffer + (setq-local indent-tabs-mode nil) + (insert "line") + (let ((current-prefix-arg nil)) + (call-interactively #'cj/indent-lines-in-region-or-buffer)) + (should (string= " line" (buffer-string))))) + +(ert-deftest test-indent-lines-interactive-follows-indent-tabs-mode () + "Interactive: tabs-vs-spaces follows `indent-tabs-mode', not the prefix arg." + (with-temp-buffer + (setq-local indent-tabs-mode t) + (insert "line") + (let ((current-prefix-arg nil)) + (call-interactively #'cj/indent-lines-in-region-or-buffer)) + (should (string= "\t\t\t\tline" (buffer-string))))) + +(ert-deftest test-dedent-lines-interactive-no-prefix-is-four () + "Interactive: no prefix removes up to 4 leading whitespace characters." + (with-temp-buffer + (insert " line") ; eight leading spaces + (let ((current-prefix-arg nil)) + (call-interactively #'cj/dedent-lines-in-region-or-buffer)) + (should (string= " line" (buffer-string))))) + ;;; Indent Tests - Normal Cases with Spaces (ert-deftest test-indent-single-line-4-spaces () diff --git a/tests/test-dashboard-config-launchers.el b/tests/test-dashboard-config-launchers.el index 53c46caa..76fbcc42 100644 --- a/tests/test-dashboard-config-launchers.el +++ b/tests/test-dashboard-config-launchers.el @@ -28,20 +28,21 @@ ;; Telegram moved from "g" to "G" so "g" is free for dashboard refresh. ;; Signal ("S") added as the 14th launcher. ;; Weather ("w") added after Agenda as the 15th launcher (top-row daily glance). -(defconst test-dash--keys '("c" "d" "t" "a" "w" "r" "b" "f" "m" "e" "i" "G" "s" "l" "S")) +(defconst test-dash--keys '("c" "d" "t" "a" "w" "r" "b" "f" "m" "e" "i" "G" "s" "l")) ;; ----------------------------- launcher table -------------------------------- (ert-deftest test-dashboard-launchers-keys-in-order () - "Normal: 15 launchers with the expected keys in display order." - (should (= 15 (length cj/dashboard--launchers))) + "Normal: 14 launchers with the expected keys in display order. +(Signal left the table when the signel client was retired to archive/.)" + (should (= 14 (length cj/dashboard--launchers))) (should (equal test-dash--keys (mapcar (lambda (l) (nth 0 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-launchers-labels-in-order () "Normal: labels in display order (Telegram and Slack reordered so Slack sits next to Linear on the last navigator row)." (should (equal '("Code" "Files" "Terminal" "Agenda" "Weather" "Feeds" "Books" - "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear" "Signal") + "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear") (mapcar (lambda (l) (nth 3 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-row-sizes-cover-all-launchers () @@ -51,9 +52,9 @@ next to Linear on the last navigator row)." ;; --------------------------- navigator rows ---------------------------------- -(ert-deftest test-dashboard-navigator-rows-grouped-5-4-3-3 () - "Normal: navigator derives rows per `cj/dashboard--row-sizes' (5 4 3 3), with -Weather joining the top row and Slack, Linear, and Signal sharing the last row." +(ert-deftest test-dashboard-navigator-rows-grouped-5-4-3-2 () + "Normal: navigator derives rows per `cj/dashboard--row-sizes' (5 4 3 2), with +Weather joining the top row and Slack and Linear pairing on the last row." (cl-letf (((symbol-function 'nerd-icons-faicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-devicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-mdicon) (lambda (n &rest _) (concat "I:" n))) @@ -62,10 +63,10 @@ Weather joining the top row and Slack, Linear, and Signal sharing the last row." ((symbol-function 'nerd-icons-wicon) (lambda (n &rest _) (concat "I:" n)))) (let ((rows (cj/dashboard--navigator-rows))) (should (= 4 (length rows))) - (should (equal '(5 4 3 3) (mapcar #'length rows))) + (should (equal '(5 4 3 2) (mapcar #'length rows))) (should (equal '("Code" "Files" "Terminal" "Agenda" "Weather") (mapcar (lambda (b) (nth 1 b)) (nth 0 rows)))) - (should (equal '("Slack" "Linear" "Signal") + (should (equal '("Slack" "Linear") (mapcar (lambda (b) (nth 1 b)) (nth 3 rows)))) (let ((btn (car (car rows)))) ; (icon label tooltip action nil " " "") (should (string= "I:nf-fa-code" (nth 0 btn))) @@ -100,7 +101,6 @@ Weather joining the top row and Slack, Linear, and Signal sharing the last row." ((symbol-function 'cj/slack-start) (lambda (&rest _) (push 'slack calls))) ((symbol-function 'cj/telega) (lambda (&rest _) (push 'tg calls))) ((symbol-function 'pearl-list-issues) (lambda (&rest _) (push 'linear calls))) - ((symbol-function 'cj/signel-message) (lambda (&rest _) (push 'signal calls))) ;; wttrin is invoked via `call-interactively', so the stub must be ;; a command -- a plain variadic lambda masked the real arity bug. ((symbol-function 'wttrin) (lambda (&rest _) (interactive) (push 'weather calls)))) @@ -112,9 +112,8 @@ Weather joining the top row and Slack, Linear, and Signal sharing the last row." (should (memq 'linear calls)) (should (memq 'm-toggle calls)) (should (memq 'm-load calls)) - (should (memq 'signal calls)) (should (memq 'weather calls)) - (should (= 16 (length calls)))))) ; 15 keys, Music fires two + (should (= 15 (length calls)))))) ; 14 keys, Music fires two (provide 'test-dashboard-config-launchers) ;;; test-dashboard-config-launchers.el ends here diff --git a/tests/test-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-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--quantize-thumb-size.el b/tests/test-dirvish-config--quantize-thumb-size.el new file mode 100644 index 00000000..a26ef090 --- /dev/null +++ b/tests/test-dirvish-config--quantize-thumb-size.el @@ -0,0 +1,60 @@ +;;; test-dirvish-config--quantize-thumb-size.el --- thumbnail width-bucket tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--dirvish-quantize-thumb-size' rounds dirvish's computed thumbnail size to +;; a coarse pixel bucket so small preview-window jitter maps to one stable cache +;; key instead of a fresh miss + regenerate (the webm thumbnail-flash bug). Pure +;; math; the :filter-return advice that wires it onto `dirvish-media--img-size' +;; is verified live. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'dirvish-config) + +(declare-function cj/--dirvish-quantize-thumb-size "dirvish-config" (size bucket)) + +;;; ------------------------------- rounding ----------------------------------- + +(ert-deftest test-dirvish-quantize-rounds-down () + "Normal: a size below the bucket midpoint rounds down to the bucket." + (should (= (cj/--dirvish-quantize-thumb-size 931 100) 900))) + +(ert-deftest test-dirvish-quantize-rounds-up () + "Normal: a size above the bucket midpoint rounds up to the next bucket." + (should (= (cj/--dirvish-quantize-thumb-size 552 100) 600))) + +(ert-deftest test-dirvish-quantize-on-bucket-unchanged () + "Normal: a size already on a bucket boundary is returned unchanged." + (should (= (cj/--dirvish-quantize-thumb-size 600 100) 600))) + +(ert-deftest test-dirvish-quantize-jitter-maps-to-one-key () + "Boundary: nearby sizes within a bucket collapse to the same cache key." + (should (= (cj/--dirvish-quantize-thumb-size 931 100) + (cj/--dirvish-quantize-thumb-size 949 100)))) + +(ert-deftest test-dirvish-quantize-float-input () + "Boundary: a float size (pre-floor) still yields an integer bucket." + (let ((r (cj/--dirvish-quantize-thumb-size 931.4 100))) + (should (integerp r)) + (should (= r 900)))) + +;;; ------------------------------- clamping ----------------------------------- + +(ert-deftest test-dirvish-quantize-tiny-clamps-to-bucket () + "Boundary: a size that would round to 0 clamps up to one bucket, never 0." + (should (= (cj/--dirvish-quantize-thumb-size 1 100) 100))) + +;;; ------------------------------ disabled path ------------------------------- + +(ert-deftest test-dirvish-quantize-zero-bucket-passthrough () + "Error/disabled: a zero bucket returns the size unchanged." + (should (= (cj/--dirvish-quantize-thumb-size 931 0) 931))) + +(ert-deftest test-dirvish-quantize-nil-bucket-passthrough () + "Error/disabled: a nil bucket returns the size unchanged." + (should (= (cj/--dirvish-quantize-thumb-size 931 nil) 931))) + +(provide 'test-dirvish-config--quantize-thumb-size) +;;; test-dirvish-config--quantize-thumb-size.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-eat-config--xtwinops.el b/tests/test-eat-config--xtwinops.el new file mode 100644 index 00000000..29f87f2f --- /dev/null +++ b/tests/test-eat-config--xtwinops.el @@ -0,0 +1,120 @@ +;;; test-eat-config--xtwinops.el --- Tests for the EAT XTWINOPS window-size reply -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for the XTWINOPS (CSI <n> t) window-size responder. eat 0.9.4 +;; has no CSI <n> t handler, so it silently drops the window-size requests +;; tmux 3.7b sends to learn the cell pixel size it needs before it will emit +;; Sixel -- images then never render inside EAT. The module answers three +;; requests: 14 (text area in pixels), 16 (cell size in pixels), 18 (text area +;; in characters). +;; +;; Two pure pieces carry the logic and are tested here directly: +;; - `cj/--eat-xtwinops-report' computes the reply string from the display and +;; cell dimensions. +;; - `cj/--eat-xtwinops-queries' extracts the request numbers from a chunk of +;; terminal output. +;; The thin accessor glue (`cj/--eat-send-window-size-report', which reads the +;; live `eat--t-term' struct) is verified in the running daemon, since eat's +;; structs are not loadable under `make test' (no package-initialize). The +;; detector's dispatch is tested against a recording stub of the responder. + +;;; Code: + +(require 'ert) + +;; Stub keymap dep before loading the module (matches the other module tests). +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'eat-config) + +;;; --------------------------- reply computation ---------------------------- + +(ert-deftest test-eat-config-xtwinops-report-normal-14-text-area-pixels () + "Normal: request 14 reports text-area size in pixels (rows*ch by cols*cw)." + ;; 80x24 chars, 10x20 px cells -> height 24*20=480, width 80*10=800. + (should (equal (cj/--eat-xtwinops-report 14 80 24 10 20) + "\e[4;480;800t"))) + +(ert-deftest test-eat-config-xtwinops-report-normal-16-cell-pixels () + "Normal: request 16 reports the cell size in pixels (height then width)." + (should (equal (cj/--eat-xtwinops-report 16 80 24 10 20) + "\e[6;20;10t"))) + +(ert-deftest test-eat-config-xtwinops-report-normal-18-text-area-chars () + "Normal: request 18 reports the text-area size in characters (rows then cols)." + (should (equal (cj/--eat-xtwinops-report 18 80 24 10 20) + "\e[8;24;80t"))) + +(ert-deftest test-eat-config-xtwinops-report-boundary-unit-cells () + "Boundary: with eat's default 1x1 px cells, pixel dims equal the char dims." + (should (equal (cj/--eat-xtwinops-report 14 80 24 1 1) "\e[4;24;80t")) + (should (equal (cj/--eat-xtwinops-report 16 80 24 1 1) "\e[6;1;1t"))) + +(ert-deftest test-eat-config-xtwinops-report-error-unknown-request-is-nil () + "Error: any request number other than 14/16/18 returns nil (unanswered)." + (should (null (cj/--eat-xtwinops-report 15 80 24 10 20))) + (should (null (cj/--eat-xtwinops-report 24 80 24 10 20))) + (should (null (cj/--eat-xtwinops-report nil 80 24 10 20)))) + +;;; ----------------------------- query detection ---------------------------- + +(ert-deftest test-eat-config-xtwinops-queries-normal-single () + "Normal: a lone CSI 14 t query is detected." + (should (equal (cj/--eat-xtwinops-queries "\e[14t") '(14)))) + +(ert-deftest test-eat-config-xtwinops-queries-normal-embedded-multiple () + "Normal: several queries embedded in other output are returned in order." + (should (equal (cj/--eat-xtwinops-queries "foo\e[14tbar\e[18tbaz\e[16t") + '(14 18 16)))) + +(ert-deftest test-eat-config-xtwinops-queries-boundary-none () + "Boundary: output with no XTWINOPS query returns nil, including empty." + (should (null (cj/--eat-xtwinops-queries ""))) + (should (null (cj/--eat-xtwinops-queries "hello\e[0m\e[2J")))) + +(ert-deftest test-eat-config-xtwinops-queries-error-unhandled-ops-ignored () + "Error: CSI t ops we do not answer (and parametrized forms) are not matched. +`\\e[24t' is a resize op, `\\e[3;14t' carries a leading param -- neither is the +bare CSI 14/16/18 t we answer, so both are ignored." + (should (null (cj/--eat-xtwinops-queries "\e[24t"))) + (should (null (cj/--eat-xtwinops-queries "\e[3;14t"))) + (should (null (cj/--eat-xtwinops-queries "\e[114t")))) + +;;; --------------------------- advice-needed guard -------------------------- + +(ert-deftest test-eat-config-xtwinops-advice-needed-normal-eat-0-9-4 () + "Normal: on eat 0.9.4 (no upstream CSI t clause) the advice is needed." + ;; The upstream parser clause defines `eat--t-send-window-size-report'; + ;; 0.9.4 does not, so it must be unbound here. + (should-not (fboundp 'eat--t-send-window-size-report)) + (should (cj/--eat-xtwinops-advice-needed-p))) + +(ert-deftest test-eat-config-xtwinops-advice-needed-boundary-upstream-ships () + "Boundary: once upstream defines the parser clause, the advice must NOT +install -- both would answer and tmux gets a double reply." + (cl-letf (((symbol-function 'eat--t-send-window-size-report) #'ignore)) + (should-not (cj/--eat-xtwinops-advice-needed-p)))) + +;;; ------------------------- detector dispatch (seam) ----------------------- + +(ert-deftest test-eat-config-xtwinops-answer-dispatches-once-per-query () + "Integration: the detector calls the responder once per query, in order. +Mocks only our own responder seam (`cj/--eat-send-window-size-report'); the +detector under test does the real query extraction." + (let ((calls '())) + (cl-letf (((symbol-function 'cj/--eat-send-window-size-report) + (lambda (n) (push n calls)))) + (cj/--eat-answer-xtwinops "\e[14t\e[16t\e[18t")) + (should (equal (nreverse calls) '(14 16 18))))) + +(ert-deftest test-eat-config-xtwinops-answer-no-query-no-call () + "Boundary: output with no query never calls the responder." + (let ((called nil)) + (cl-letf (((symbol-function 'cj/--eat-send-window-size-report) + (lambda (_n) (setq called t)))) + (cj/--eat-answer-xtwinops "no query here\e[2J")) + (should-not called))) + +(provide 'test-eat-config--xtwinops) +;;; test-eat-config--xtwinops.el ends here 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..3b2d32b8 100644 --- a/tests/test-external-open-commands.el +++ b/tests/test-external-open-commands.el @@ -64,19 +64,28 @@ (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 diff --git a/tests/test-flycheck-config-ledger-hook.el b/tests/test-flycheck-config-ledger-hook.el new file mode 100644 index 00000000..e9444b71 --- /dev/null +++ b/tests/test-flycheck-config-ledger-hook.el @@ -0,0 +1,31 @@ +;;; test-flycheck-config-ledger-hook.el --- flycheck reaches ledger buffers -*- lexical-binding: t; -*- + +;;; Commentary: +;; `flycheck-ledger' registers a `ledger' checker, but a checker only runs where +;; `flycheck-mode' is on. Until 2026-07-10 flycheck-config enabled the mode in +;; `sh-mode' and `emacs-lisp-mode' only, and no `global-flycheck-mode' existed, so +;; an unbalanced transaction in a ledger file produced no warning at all. +;; +;; These tests pin the hook, not the checker. Whether the `ledger' checker itself +;; works is flycheck-ledger's problem; whether it ever gets a chance to run is ours. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'flycheck-config) + +(ert-deftest test-flycheck-config-enables-flycheck-in-ledger-buffers () + "Normal: opening a ledger buffer turns `flycheck-mode' on. +Without this, `flycheck-ledger' is loaded, its checker is registered, and +nothing ever lints a financial file." + (should (memq #'flycheck-mode (default-value 'ledger-mode-hook)))) + +(ert-deftest test-flycheck-config-keeps-its-existing-mode-hooks () + "Boundary: adding ledger doesn't displace the modes flycheck already covered." + (should (memq #'flycheck-mode (default-value 'sh-mode-hook))) + (should (memq #'flycheck-mode (default-value 'emacs-lisp-mode-hook)))) + +(provide 'test-flycheck-config-ledger-hook) +;;; test-flycheck-config-ledger-hook.el ends here diff --git a/tests/test-flyspell-and-abbrev.el b/tests/test-flyspell-and-abbrev.el index ef8cc637..3b494d5e 100644 --- a/tests/test-flyspell-and-abbrev.el +++ b/tests/test-flyspell-and-abbrev.el @@ -97,5 +97,27 @@ (cj/flyspell-on-for-buffer-type))) (should mode-called))) +;; --------------------------- cj/flyspell-then-abbrev ------------------------- + +(ert-deftest test-flyspell-then-abbrev-enables-mode-not-bare-rescan () + "Regression: cj/flyspell-then-abbrev routes the initial scan through +cj/flyspell-on-for-buffer-type, which enables flyspell-mode so it sticks. +The bare flyspell-buffer it replaced never turned the mode on, so the guard +never tripped and every C-' press re-scanned the whole buffer (O(buffer) per +keypress in large files)." + (let (on-called scan-called) + (cl-letf (((symbol-function 'cj/--require-spell-checker) #'ignore) + ((symbol-function 'cj/flyspell-on-for-buffer-type) + (lambda () (setq on-called t))) + ((symbol-function 'flyspell-buffer) + (lambda (&rest _) (setq scan-called t))) + ((symbol-function 'cj/flyspell-goto-previous-misspelling) + (lambda (&rest _) nil))) + (with-temp-buffer + (text-mode) + (cj/flyspell-then-abbrev nil))) + (should on-called) + (should-not scan-called))) + (provide 'test-flyspell-and-abbrev) ;;; test-flyspell-and-abbrev.el ends here 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 393a7758..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 @@ -93,5 +90,248 @@ ((symbol-function 'set-fontset-font) (lambda (&rest _) t))) (should (progn (cj/setup-emoji-fontset) t)))) +;;; cj/set-emojify-display-style + +(defvar emojify-display-style) + +(ert-deftest test-font-config-emojify-display-style-image-on-gui () + "Normal: on a GUI frame the emoji display style is `image'." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((emojify-display-style nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) t))) + (cj/set-emojify-display-style) + (should (eq emojify-display-style 'image))))) + +(ert-deftest test-font-config-emojify-display-style-unicode-without-gui () + "Boundary: without a GUI the emoji display style is `unicode'." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((emojify-display-style nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) nil))) + (cj/set-emojify-display-style) + (should (eq emojify-display-style 'unicode))))) + +;;; cj/display-available-fonts + +(ert-deftest test-font-config-display-available-fonts-second-call-no-error () + "Error: a second invocation does not signal on the read-only buffer." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'font-family-list) + (lambda (&rest _) '("Fixture Font A" "Fixture Font B")))) + (unwind-protect + (progn + (cj/display-available-fonts) + ;; The first call ends in `special-mode' (read-only); the second must + ;; not signal when it erases and rewrites the buffer. + (cj/display-available-fonts) + (with-current-buffer "*Available Fonts*" + (should (> (buffer-size) 0)) + (should buffer-read-only))) + (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-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-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-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-keyboard-compat-setup.el b/tests/test-keyboard-compat-setup.el index 1c5cd434..a23e24e1 100644 --- a/tests/test-keyboard-compat-setup.el +++ b/tests/test-keyboard-compat-setup.el @@ -61,6 +61,14 @@ string can return a meta-prefix event count rather than nil.)" (cj/keyboard-compat-terminal-setup) (should (equal input-decode-map (make-sparse-keymap))))) +(ert-deftest test-keyboard-compat-terminal-setup-on-tty-setup-hook () + "Normal: terminal setup is registered on `tty-setup-hook', which runs for each +new tty frame. `input-decode-map' is terminal-local, so `emacs-startup-hook' +\(once, at daemon start, with no tty) leaves every later `emacsclient -t' frame +without the arrow-key decodings. The GUI half already frame-scopes itself." + (should (memq 'cj/keyboard-compat-terminal-setup tty-setup-hook)) + (should-not (memq 'cj/keyboard-compat-terminal-setup emacs-startup-hook))) + ;; -------------------------- cj/keyboard-compat-gui-setup --------------------- (defmacro test-kbc--gui (gui-p &rest body) @@ -71,18 +79,20 @@ string can return a meta-prefix event count rather than nil.)" ,@body))) (defconst test-kbc--meta-shift-letters - '(?o ?m ?y ?f ?w ?e ?l ?r ?v ?h ?t ?z ?u ?d ?i ?c ?b ?k) - "The 18 letters whose M-<UPPER> form is translated to M-S-<lower> in GUI mode.") + '(?o ?m ?y ?f ?w ?e ?l ?r ?v ?h ?t ?z ?u ?d ?i ?c ?b) + "The 17 letters whose M-<UPPER> form is translated to M-S-<lower> in GUI mode.") (ert-deftest test-keyboard-compat-gui-setup-translates-spot-checks () - "Normal: in GUI mode, M-O -> M-S-o and M-K -> M-S-k (sampled)." + "Normal: in GUI mode, M-O -> M-S-o and M-B -> M-S-b (sampled). +M-K is no longer translated: show-kill-ring, its only consumer, was retired." (test-kbc--gui t (cj/keyboard-compat-gui-setup) (should (equal (lookup-key key-translation-map (kbd "M-O")) (kbd "M-S-o"))) - (should (equal (lookup-key key-translation-map (kbd "M-K")) (kbd "M-S-k"))) - (should (equal (lookup-key key-translation-map (kbd "M-D")) (kbd "M-S-d"))))) + (should (equal (lookup-key key-translation-map (kbd "M-B")) (kbd "M-S-b"))) + (should (equal (lookup-key key-translation-map (kbd "M-D")) (kbd "M-S-d"))) + (should-not (lookup-key key-translation-map (kbd "M-K"))))) -(ert-deftest test-keyboard-compat-gui-setup-translates-all-eighteen () +(ert-deftest test-keyboard-compat-gui-setup-translates-all-seventeen () "Normal: every documented M-<UPPER> maps to its M-S-<lower> form." (test-kbc--gui t (cj/keyboard-compat-gui-setup) diff --git a/tests/test-ledger-config.el b/tests/test-ledger-config.el new file mode 100644 index 00000000..5224c184 --- /dev/null +++ b/tests/test-ledger-config.el @@ -0,0 +1,70 @@ +;;; test-ledger-config.el --- Characterization tests for ledger-config -*- lexical-binding: t; -*- + +;;; Commentary: +;; Captures the behavior ledger-config.el has today, before any guardrail work +;; changes it. See docs/design/2026-07-10-ledger-config-audit.org for the audit +;; these tests pin. +;; +;; The clean-on-save helpers are defined in the `use-package' `:preface', which +;; use-package emits unconditionally, so they exist under `make test' even though +;; ledger-mode itself never loads there (no `package-initialize' in the test run). +;; +;; `ledger-mode-clean-buffer' is stubbed: it is the boundary this config delegates +;; to, and it rewrites the whole buffer. What these tests pin is whether our hook +;; calls it, not what it does. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ledger-config) + +(ert-deftest test-ledger-config-clean-before-save-cleans-when-enabled () + "Normal: with `cj/ledger-clean-on-save' set, the save hook cleans the buffer." + (let ((called 0) + (cj/ledger-clean-on-save t)) + (cl-letf (((symbol-function 'ledger-mode-clean-buffer) + (lambda (&rest _) (setq called (1+ called))))) + (cj/ledger--clean-before-save)) + (should (= 1 called)))) + +(ert-deftest test-ledger-config-clean-before-save-skips-when-disabled () + "Boundary: with `cj/ledger-clean-on-save' nil, the save hook does nothing." + (let ((called 0) + (cj/ledger-clean-on-save nil)) + (cl-letf (((symbol-function 'ledger-mode-clean-buffer) + (lambda (&rest _) (setq called (1+ called))))) + (cj/ledger--clean-before-save)) + (should (= 0 called)))) + +(ert-deftest test-ledger-config-clean-before-save-demotes-errors () + "Error: a failing clean does not signal, so the file still saves. +This is the current contract. It also means a clean that fails partway +leaves the buffer in whatever state it reached, because nothing rolls back." + (let ((cj/ledger-clean-on-save t) + (inhibit-message t)) + (cl-letf (((symbol-function 'ledger-mode-clean-buffer) + (lambda (&rest _) (error "boom")))) + (should (progn (cj/ledger--clean-before-save) t))))) + +(ert-deftest test-ledger-config-enable-clean-on-save-is-buffer-local () + "Normal: the hook installs buffer-locally, not globally." + (let ((global-before (default-value 'before-save-hook))) + (with-temp-buffer + (cj/ledger--enable-clean-on-save) + (should (memq #'cj/ledger--clean-before-save before-save-hook)) + (should-not (memq #'cj/ledger--clean-before-save + (default-value 'before-save-hook)))) + (should (equal global-before (default-value 'before-save-hook))))) + +(ert-deftest test-ledger-config-clean-on-save-defaults-on () + "Normal: clean-on-save ships enabled. +Pinned because the audit questions whether a whole-buffer sort belongs on +every save of a financial file. If that default flips, this test should +fail and be updated deliberately." + (should (eq t (default-value 'cj/ledger-clean-on-save)))) + +(provide 'test-ledger-config) +;;; test-ledger-config.el ends here diff --git a/tests/test-local-repository--car-member.el b/tests/test-local-repository--car-member.el deleted file mode 100644 index 30ae58c6..00000000 --- a/tests/test-local-repository--car-member.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; test-local-repository--car-member.el --- Tests for localrepo--car-member -*- lexical-binding: t -*- - -;;; Commentary: -;; Tests for `localrepo--car-member' in local-repository.el — the predicate -;; localrepo-initialize uses to check whether an archive id is already -;; registered in package-archives / package-archive-priorities. - -;;; Code: - -(require 'ert) -(require 'local-repository) - -;;; Normal Cases - -(ert-deftest test-local-repository-localrepo--car-member-found () - "Normal: VALUE present as a car returns the matching tail (non-nil)." - (should (equal (localrepo--car-member 'b '((a . 1) (b . 2) (c . 3))) - '(b c)))) - -(ert-deftest test-local-repository-localrepo--car-member-not-found () - "Normal: VALUE absent from every car returns nil." - (should-not (localrepo--car-member 'z '((a . 1) (b . 2))))) - -(ert-deftest test-local-repository-localrepo--car-member-string-car () - "Normal: car comparison uses `equal', so string keys match by value." - (should (localrepo--car-member "localrepo" - '(("gnu" . "url1") ("localrepo" . "url2"))))) - -;;; Boundary Cases - -(ert-deftest test-local-repository-localrepo--car-member-empty-list () - "Boundary: an empty list never matches." - (should-not (localrepo--car-member 'a nil))) - -(ert-deftest test-local-repository-localrepo--car-member-single-match () - "Boundary: a single-element list whose car matches returns non-nil." - (should (localrepo--car-member 'only '((only . 1))))) - -(ert-deftest test-local-repository-localrepo--car-member-single-no-match () - "Boundary: a single-element list whose car differs returns nil." - (should-not (localrepo--car-member 'x '((only . 1))))) - -(ert-deftest test-local-repository-localrepo--car-member-nil-value-with-nil-car () - "Boundary: a nil VALUE matches a cons whose car is nil." - (should (localrepo--car-member nil '((nil . 1) (a . 2))))) - -(ert-deftest test-local-repository-localrepo--car-member-nil-value-no-nil-car () - "Boundary: a nil VALUE with no nil car returns nil." - (should-not (localrepo--car-member nil '((a . 1) (b . 2))))) - -;;; Error Cases - -(ert-deftest test-local-repository-localrepo--car-member-non-cons-element () - "Error: a non-cons element makes `car' signal wrong-type-argument." - (should-error (localrepo--car-member 'x '(1 2)) :type 'wrong-type-argument)) - -(provide 'test-local-repository--car-member) -;;; test-local-repository--car-member.el ends here diff --git a/tests/test-local-repository.el b/tests/test-local-repository.el new file mode 100644 index 00000000..132f8dc4 --- /dev/null +++ b/tests/test-local-repository.el @@ -0,0 +1,32 @@ +;;; test-local-repository.el --- Tests for the local-repository update command -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/update-localrepo-repository' refreshes the checked-in local package +;; archive at `localrepo-location' (owned by early-init.el) via elpa-mirror. +;; The elpa-mirror call is mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'local-repository) + +;; localrepo-location is a defconst in early-init.el, which `make test' never +;; loads. Declare it special here so the `let' below binds it dynamically and +;; the module reads that value. +(defvar localrepo-location nil) + +(ert-deftest test-local-repository-update-targets-early-init-location () + "Normal: the mirror update targets `localrepo-location', the single archive +path early-init.el owns, not a divergent module-local copy." + (let ((localrepo-location "/tmp/test-localrepo/") + (captured nil)) + (cl-letf (((symbol-function 'elpamr-create-mirror-for-installed) + (lambda (dir &rest _) (setq captured dir)))) + (cj/update-localrepo-repository) + (should (equal captured "/tmp/test-localrepo/"))))) + +(provide 'test-local-repository) +;;; test-local-repository.el ends here diff --git a/tests/test-lorem-optimum.el b/tests/test-lorem-optimum.el index f928c972..b7d97a8e 100644 --- a/tests/test-lorem-optimum.el +++ b/tests/test-lorem-optimum.el @@ -253,5 +253,26 @@ an empty string, not an error." (let ((cj/lipsum-chain (cj/markov-chain-create))) (should (equal "" (cj/lipsum-title))))) +;;; cj/lipsum entry point + +(ert-deftest test-lipsum-returns-string-with-populated-chain () + "Normal: cj/lipsum returns a non-empty string when the chain is trained." + (let ((cj/lipsum-chain + (test-learn "Lorem ipsum dolor sit amet consectetur adipiscing elit"))) + (let ((result (cj/lipsum 5))) + (should (stringp result)) + (should (> (length result) 0))))) + +(ert-deftest test-lipsum-empty-chain-signals-user-error () + "Error: cj/lipsum on an empty chain signals a user-error naming the fix, +rather than returning nil and letting cj/lipsum-insert do (insert nil), +which raises a cryptic wrong-type error far from the cause." + (let ((cj/lipsum-chain (cj/markov-chain-create))) + (should-error (cj/lipsum 5) :type 'user-error))) + +(ert-deftest test-lipsum-is-interactive-command () + "Normal: cj/lipsum is a command, as its Commentary (M-x cj/lipsum) advertises." + (should (commandp 'cj/lipsum))) + (provide 'test-lorem-optimum) ;;; test-lorem-optimum.el ends here diff --git a/tests/test-mail-config--account-search-queries.el b/tests/test-mail-config--account-search-queries.el index 9f1b6b3e..02a74692 100644 --- a/tests/test-mail-config--account-search-queries.el +++ b/tests/test-mail-config--account-search-queries.el @@ -38,9 +38,12 @@ (ert-deftest test-mail-make-account-map-closures-capture-distinct-queries () "Normal: each binding runs its own account-scoped search (no closure leak). -mu4e-search is mocked to capture the query each command passes." +mu4e-search is mocked to capture the query each command passes; require is +mocked so the commands' mu4e load never pulls the real package in batch." (let ((searched '())) - (cl-letf (((symbol-function 'mu4e-search) + (cl-letf (((symbol-function 'require) + (lambda (feature &rest _) feature)) + ((symbol-function 'mu4e-search) (lambda (q) (push q searched)))) (let ((map (cj/--mail-make-account-map "dmail"))) (funcall (keymap-lookup map "i")) @@ -49,5 +52,20 @@ mu4e-search is mocked to capture the query each command passes." (should (member "maildir:/dmail/INBOX AND flag:unread AND NOT flag:trashed" searched)))) +(ert-deftest test-mail-make-account-map-loads-mu4e-before-search () + "Error: a nav command loads mu4e before it calls `mu4e-search'. +The C-; e maps register eagerly at startup, but `mu4e-search' carries no +autoload cookie, so a nav key pressed before mu4e's first launch signaled +void-function. The command must require mu4e first, then search." + (let ((events '())) + (cl-letf (((symbol-function 'require) + (lambda (feature &rest _) (push (list :require feature) events) feature)) + ((symbol-function 'mu4e-search) + (lambda (q) (push (list :search q) events)))) + (funcall (keymap-lookup (cj/--mail-make-account-map "cmail") "i"))) + (should (equal (nreverse events) + '((:require mu4e) + (:search "maildir:/cmail/INBOX")))))) + (provide 'test-mail-config--account-search-queries) ;;; test-mail-config--account-search-queries.el ends here diff --git a/tests/test-mail-config-transport.el b/tests/test-mail-config-transport.el index 0240102a..9329ac70 100644 --- a/tests/test-mail-config-transport.el +++ b/tests/test-mail-config-transport.el @@ -66,6 +66,23 @@ EXECUTABLES is an alist of program name strings to executable paths." (should (equal test-mail-config--warnings '((mail-config . "msmtp not found; SMTP mail sending unavailable"))))))) +(ert-deftest test-mail-config-transport-msmtp-missing-sets-descriptive-fallback () + "Error: with msmtp absent, the send functions get a descriptive fallback. +The old behavior left `message-send-mail-function' nil (the top-level defvar +pre-empts message.el's default), so the first send died with \"invalid +function: nil\". The fallback must be installed on both send variables and +must signal a `user-error' that names msmtp." + (test-mail-config--with-executables nil + (let (send-mail-function message-send-mail-function) + (cj/mail-configure-smtpmail) + (should (eq send-mail-function #'cj/mail--send-mail-unavailable)) + (should (eq message-send-mail-function #'cj/mail--send-mail-unavailable)) + (should-error (cj/mail--send-mail-unavailable) :type 'user-error) + (condition-case err + (cj/mail--send-mail-unavailable) + (user-error + (should (string-match-p "msmtp" (cadr err)))))))) + (ert-deftest test-mail-config-transport-mbsync-present-builds-command () "When mbsync exists, build the mu4e sync command." (test-mail-config--with-executables '(("mbsync" . "/usr/bin/mbsync")) 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.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-mu4e-attachments.el b/tests/test-mu4e-attachments.el index 0a780977..986c2746 100644 --- a/tests/test-mu4e-attachments.el +++ b/tests/test-mu4e-attachments.el @@ -75,6 +75,56 @@ so this fails the same way whether or not mu4e's MIME support is loadable." (should-error (cj/mu4e--save-attachment-part part "/downloads") :type 'user-error))) +(ert-deftest test-mu4e-attachments-save-part-errors-on-stale-handle () + "Error: a handle whose MIME buffer was killed fails with a clear error. +The selection buffer captures handles when it opens; a real MIME handle's +car is the buffer holding the part's bytes, and viewing another message +kills it. Saving through it must signal a `user-error' naming the file, +not die in `mm-save-part-to-file' (or save another message's bytes)." + (let* ((dead (generate-new-buffer "stale-mime-part")) + (part (test-mu4e-attachments--part "invoice.pdf" 3 (list dead)))) + (kill-buffer dead) + (should-error (cj/mu4e--save-attachment-part part "/downloads") + :type 'user-error) + (condition-case err + (cj/mu4e--save-attachment-part part "/downloads") + (user-error (should (string-match-p "invoice\\.pdf" (cadr err))))))) + +(ert-deftest test-mu4e-attachments-save-part-live-buffer-handle-saves () + "Normal: a handle whose MIME buffer is alive saves normally." + (let* ((live (generate-new-buffer "live-mime-part")) + (part (test-mu4e-attachments--part "invoice.pdf" 3 (list live))) + (mu4e-uniquify-save-file-name-function #'identity) + saved) + (unwind-protect + (cl-letf (((symbol-function 'mu4e-join-paths) + (lambda (&rest pieces) (mapconcat #'identity pieces "/"))) + ((symbol-function 'mm-save-part-to-file) + (lambda (_handle path) (setq saved path)))) + (should (equal (cj/mu4e--save-attachment-part part "/downloads") + "/downloads/invoice.pdf")) + (should (equal saved "/downloads/invoice.pdf"))) + (kill-buffer live)))) + +(ert-deftest test-mu4e-attachments-save-parts-mid-batch-failure-propagates () + "Error: a mid-batch save failure propagates; earlier parts stay saved. +Characterizes the batch path: no silent skip of the failing part, and the +files already written are not rolled back." + (let ((parts (list (test-mu4e-attachments--part "a.pdf" 1) + (test-mu4e-attachments--part "b.pdf" 2) + (test-mu4e-attachments--part "c.pdf" 3))) + (saved '())) + (cl-letf (((symbol-function 'cj/mu4e--save-attachment-part) + (lambda (part _dir) + (let ((name (plist-get part :filename))) + (when (equal name "b.pdf") + (user-error "Stale handle: %s" name)) + (push name saved) + name)))) + (should-error (cj/mu4e--save-attachment-parts parts "/downloads") + :type 'user-error)) + (should (equal (nreverse saved) '("a.pdf"))))) + (ert-deftest test-mu4e-attachments-save-all-prompts-once () "Normal: the save-all command prompts for a directory once and saves all parts." (let ((parts (list (test-mu4e-attachments--part "a.pdf" 1) diff --git a/tests/test-music-config--art-cache-key.el b/tests/test-music-config--art-cache-key.el new file mode 100644 index 00000000..bc869808 --- /dev/null +++ b/tests/test-music-config--art-cache-key.el @@ -0,0 +1,69 @@ +;;; test-music-config--art-cache-key.el --- Tests for cover-art cache key -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music-art--cache-key': the stable cache-file basename for +;; a track. A url with a known #RADIOBROWSERUUID keys on the uuid (so the same +;; station shares one cached logo); any other url keys on a hash of its address; +;; a file keys on a hash of its path. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +(ert-deftest test-music-config--art-cache-key-normal-uuid () + "Normal: a url with a UUID in the entries keys on the UUID." + (let ((track (emms-track 'url "https://ck.somafm.com/gs")) + (entries '(("https://ck.somafm.com/gs" :name "GS" :uuid "uuid-42" :favicon nil)))) + (should (string= (cj/music-art--cache-key track entries) "uuid-42")))) + +(ert-deftest test-music-config--art-cache-key-boundary-url-no-uuid () + "Boundary: a url with no UUID keys on a stable url- hash, not the raw URL." + (let* ((url "https://ck2.example.net/live") + (track (emms-track 'url url)) + (key (cj/music-art--cache-key track nil))) + (should (string-prefix-p "url-" key)) + (should (string= key (concat "url-" (sha1 url)))))) + +(ert-deftest test-music-config--art-cache-key-normal-file () + "Normal: a file keys on a file- hash of its path." + (let* ((path "/music/Kind of Blue/01.flac") + (track (emms-track 'file path))) + (should (string= (cj/music-art--cache-key track nil) + (concat "file-" (sha1 path)))))) + +(ert-deftest test-music-config--art-cache-key-boundary-empty-uuid-falls-to-hash () + "Boundary: an empty-string UUID is treated as absent, so the url hashes." + (let* ((url "https://ck3.example.net/x") + (track (emms-track 'url url)) + (entries (list (list url :name "X" :uuid "" :favicon nil)))) + (should (string= (cj/music-art--cache-key track entries) + (concat "url-" (sha1 url)))))) + +(ert-deftest test-music-config--art-cache-key-normal-track-property () + "Normal: a queued lookup station carries its uuid as a track property and +needs no entries at all." + (let ((track (emms-track 'url "https://ck4.example.net/live"))) + (emms-track-set track 'radio-uuid "prop-uuid") + (should (string= (cj/music-art--cache-key track nil) "prop-uuid")))) + +(ert-deftest test-music-config--art-cache-key-normal-property-beats-entries () + "Normal: the track property wins over a conflicting entries uuid." + (let* ((url "https://ck5.example.net/live") + (track (emms-track 'url url)) + (entries (list (list url :name "X" :uuid "entries-uuid" :favicon nil)))) + (emms-track-set track 'radio-uuid "prop-uuid") + (should (string= (cj/music-art--cache-key track entries) "prop-uuid")))) + +(provide 'test-music-config--art-cache-key) +;;; test-music-config--art-cache-key.el ends here diff --git a/tests/test-music-config--art-favicon-url.el b/tests/test-music-config--art-favicon-url.el new file mode 100644 index 00000000..9e7b92f8 --- /dev/null +++ b/tests/test-music-config--art-favicon-url.el @@ -0,0 +1,69 @@ +;;; test-music-config--art-favicon-url.el --- Tests for stream favicon URL -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music-art--favicon-url': the direct favicon image URL for +;; a url track, taken from the #RADIOBROWSERFAVICON captured at station creation. +;; A station with only a UUID resolves its favicon via a separate byuuid lookup +;; (done in the impure orchestrator), so this pure helper returns nil there. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +(ert-deftest test-music-config--art-favicon-url-normal-captured () + "Normal: a captured #RADIOBROWSERFAVICON is returned directly." + (let ((track (emms-track 'url "https://fav.somafm.com/gs")) + (entries '(("https://fav.somafm.com/gs" + :name "GS" :uuid "u1" :favicon "https://cdn.example/gs.png")))) + (should (string= (cj/music-art--favicon-url track entries) + "https://cdn.example/gs.png")))) + +(ert-deftest test-music-config--art-favicon-url-boundary-uuid-only () + "Boundary: a station with a UUID but no captured favicon returns nil +\(the byuuid lookup is the orchestrator's job)." + (let ((track (emms-track 'url "https://fav2.example.net/live")) + (entries '(("https://fav2.example.net/live" + :name "X" :uuid "u2" :favicon nil)))) + (should (null (cj/music-art--favicon-url track entries))))) + +(ert-deftest test-music-config--art-favicon-url-boundary-empty-favicon () + "Boundary: an empty-string favicon is treated as absent." + (let ((track (emms-track 'url "https://fav3.example.net/live")) + (entries '(("https://fav3.example.net/live" :name "X" :uuid "u3" :favicon "")))) + (should (null (cj/music-art--favicon-url track entries))))) + +(ert-deftest test-music-config--art-favicon-url-error-file-track () + "Error: a file track has no stream favicon URL." + (let ((track (emms-track 'file "/music/x.flac"))) + (should (null (cj/music-art--favicon-url track nil))))) + +(ert-deftest test-music-config--art-favicon-url-normal-track-property () + "Normal: a queued lookup station carries its favicon as a track property." + (let ((track (emms-track 'url "https://fp.example.net/live"))) + (emms-track-set track 'radio-favicon "https://fp.example.net/icon.png") + (should (string= (cj/music-art--favicon-url track nil) + "https://fp.example.net/icon.png")))) + +(ert-deftest test-music-config--art-favicon-url-normal-property-beats-entries () + "Normal: the track property wins over a conflicting entries favicon." + (let* ((url "https://fp2.example.net/live") + (track (emms-track 'url url)) + (entries (list (list url :name "X" :uuid nil + :favicon "https://entries.example/e.png")))) + (emms-track-set track 'radio-favicon "https://prop.example/p.png") + (should (string= (cj/music-art--favicon-url track entries) + "https://prop.example/p.png")))) + +(provide 'test-music-config--art-favicon-url) +;;; test-music-config--art-favicon-url.el ends here diff --git a/tests/test-music-config--art-valid-image.el b/tests/test-music-config--art-valid-image.el new file mode 100644 index 00000000..c8de0eda --- /dev/null +++ b/tests/test-music-config--art-valid-image.el @@ -0,0 +1,51 @@ +;;; test-music-config--art-valid-image.el --- Tests for fetched-image validation -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music-art--valid-image-p': recognize whether fetched bytes +;; are actually a displayable image, so an empty body, an HTML error page served +;; 200, or a text response is rejected before it lands in the cache. Detection +;; is by image header (`image-type-from-data'), which works headless. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +(defconst test-art--png-1x1 + (base64-decode-string + (concat "iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAQAAAC1HAwCAAAAC0lEQVR42mNk" + "YPhfDwAChwGA60e6kgAAAABJRU5ErkJggg==")) + "A minimal valid 1x1 PNG, as raw bytes.") + +(ert-deftest test-music-config--art-valid-image-normal-png () + "Normal: real PNG bytes are recognized as a valid image." + (should (cj/music-art--valid-image-p test-art--png-1x1))) + +(ert-deftest test-music-config--art-valid-image-error-html () + "Error: an HTML error page served 200 is not a valid image." + (should-not (cj/music-art--valid-image-p "<html><body>502 Bad Gateway</body></html>"))) + +(ert-deftest test-music-config--art-valid-image-error-text () + "Error: arbitrary text is not a valid image." + (should-not (cj/music-art--valid-image-p "this is not an image"))) + +(ert-deftest test-music-config--art-valid-image-boundary-empty () + "Boundary: an empty body is not a valid image." + (should-not (cj/music-art--valid-image-p ""))) + +(ert-deftest test-music-config--art-valid-image-boundary-nil () + "Boundary: nil is not a valid image." + (should-not (cj/music-art--valid-image-p nil))) + +(provide 'test-music-config--art-valid-image) +;;; test-music-config--art-valid-image.el ends here diff --git a/tests/test-music-config--bar-fill.el b/tests/test-music-config--bar-fill.el new file mode 100644 index 00000000..f6d8dac8 --- /dev/null +++ b/tests/test-music-config--bar-fill.el @@ -0,0 +1,63 @@ +;;; test-music-config--bar-fill.el --- Tests for progress-bar fill math -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--bar-fill': the pure computation of how many cells +;; of a WIDTH-cell progress bar are filled given ELAPSED and TOTAL seconds. +;; A stream (no duration) is indeterminate; the live elapsed source (mpv) is +;; wired in a later phase, so this helper only does the clamp-and-round math. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +;;; Normal + +(ert-deftest test-music-config--bar-fill-normal-half () + "Normal: halfway through fills half the cells." + (should (= (cj/music--bar-fill 30 60 20) 10))) + +(ert-deftest test-music-config--bar-fill-normal-quarter () + "Normal: a quarter elapsed rounds to a quarter of the cells." + (should (= (cj/music--bar-fill 15 60 20) 5))) + +;;; Boundary + +(ert-deftest test-music-config--bar-fill-boundary-zero-elapsed () + "Boundary: nothing elapsed fills no cells." + (should (= (cj/music--bar-fill 0 60 20) 0))) + +(ert-deftest test-music-config--bar-fill-boundary-full () + "Boundary: elapsed equal to total fills every cell." + (should (= (cj/music--bar-fill 60 60 20) 20))) + +(ert-deftest test-music-config--bar-fill-boundary-over-clamps () + "Boundary: elapsed past total clamps to full, never overflows." + (should (= (cj/music--bar-fill 90 60 20) 20))) + +(ert-deftest test-music-config--bar-fill-boundary-nil-elapsed () + "Boundary: an unknown elapsed (nil) fills no cells." + (should (= (cj/music--bar-fill nil 60 20) 0))) + +;;; Error / indeterminate + +(ert-deftest test-music-config--bar-fill-indeterminate-nil-total () + "Error: a stream (nil total) is indeterminate, not a cell count." + (should (eq (cj/music--bar-fill 30 nil 20) 'indeterminate))) + +(ert-deftest test-music-config--bar-fill-indeterminate-zero-total () + "Error: a zero total is indeterminate rather than a divide-by-zero." + (should (eq (cj/music--bar-fill 30 0 20) 'indeterminate))) + +(provide 'test-music-config--bar-fill) +;;; test-music-config--bar-fill.el ends here diff --git a/tests/test-music-config--bar-string.el b/tests/test-music-config--bar-string.el new file mode 100644 index 00000000..bb6ac96f --- /dev/null +++ b/tests/test-music-config--bar-string.el @@ -0,0 +1,50 @@ +;;; test-music-config--bar-string.el --- Tests for the block progress bar -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--bar-string': render a WIDTH-cell block bar from a +;; filled-cell count (from `cj/music--bar-fill'), or an "on air" marker when the +;; fill is `indeterminate' (a live stream with no duration). Face-carrying +;; text; the tests assert the rendered length and content, not the faces. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +(ert-deftest test-music-config--bar-string-normal-half () + "Normal: 10 of 20 cells filled renders a 20-cell bar." + (let ((s (substring-no-properties (cj/music--bar-string 10 20)))) + (should (= (length s) 20)) + (should (= (cl-count ?█ s) 10)) + (should (= (cl-count ?░ s) 10)))) + +(ert-deftest test-music-config--bar-string-boundary-empty () + "Boundary: zero fill is all empty cells." + (let ((s (substring-no-properties (cj/music--bar-string 0 20)))) + (should (= (cl-count ?█ s) 0)) + (should (= (cl-count ?░ s) 20)))) + +(ert-deftest test-music-config--bar-string-boundary-full () + "Boundary: full fill is all filled cells." + (let ((s (substring-no-properties (cj/music--bar-string 20 20)))) + (should (= (cl-count ?█ s) 20)) + (should (= (cl-count ?░ s) 0)))) + +(ert-deftest test-music-config--bar-string-indeterminate-on-air () + "Error/indeterminate: a stream renders an on-air marker, not a bar." + (let ((s (substring-no-properties (cj/music--bar-string 'indeterminate 20)))) + (should (string-match-p "on air" s)) + (should (= (cl-count ?█ s) 0)))) + +(provide 'test-music-config--bar-string) +;;; test-music-config--bar-string.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--display-name.el b/tests/test-music-config--display-name.el new file mode 100644 index 00000000..c1065f3a --- /dev/null +++ b/tests/test-music-config--display-name.el @@ -0,0 +1,139 @@ +;;; test-music-config--display-name.el --- Tests for track display-name -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--display-name' and `cj/music--format-meta'. +;; +;; display-name is the pure, name-only resolver shared by the header's Current +;; line and the playlist row renderer: for a tagged track it returns +;; "Artist - Title" (no duration -- duration is right-aligned meta, not name); +;; for an untagged file the clean filename; for a url track the #EXTINF label +;; from a passed name-map, else a tidied host; unknown types fall back to +;; emms-track-simple-description. +;; +;; format-meta returns the right-aligned meta string for a row: a file's +;; duration as "[M:SS]", empty otherwise. +;; +;; Track independence: `emms-track' returns a track cached by (type . name) +;; once EMMS is loaded, so two tests sharing a name would share a mutated +;; object. Every test below uses a UNIQUE track name to stay independent. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +;;; Helpers + +(defun test-display-name--file (path &optional title artist duration) + "Create a file TRACK with PATH and optional TITLE ARTIST DURATION." + (let ((track (emms-track 'file path))) + (when title (emms-track-set track 'info-title title)) + (when artist (emms-track-set track 'info-artist artist)) + (when duration (emms-track-set track 'info-playing-time duration)) + track)) + +(defun test-display-name--url (url &optional title artist) + "Create a url TRACK with URL and optional TITLE ARTIST." + (let ((track (emms-track 'url url))) + (when title (emms-track-set track 'info-title title)) + (when artist (emms-track-set track 'info-artist artist)) + track)) + +;;; Normal -- tagged tracks (no duration in the name) + +(ert-deftest test-music-config--display-name-normal-artist-title () + "Normal: tagged track shows Artist - Title, no duration bracket." + (let ((track (test-display-name--file + "/dn/artist-title.flac" "So What" "Miles Davis" 562))) + (should (string= (cj/music--display-name track) "Miles Davis - So What")))) + +(ert-deftest test-music-config--display-name-normal-title-only () + "Normal: title without artist shows the title alone." + (let ((track (test-display-name--file "/dn/title-only.mp3" "Flamenco Sketches" nil 566))) + (should (string= (cj/music--display-name track) "Flamenco Sketches")))) + +;;; Normal -- untagged file + +(ert-deftest test-music-config--display-name-normal-file-no-tags () + "Normal: untagged file shows filename without path or extension." + (let ((track (test-display-name--file "/dn/Kind of Blue/02 - Freddie.flac"))) + (should (string= (cj/music--display-name track) "02 - Freddie")))) + +;;; Normal -- url resolves to #EXTINF label from the name-map + +(ert-deftest test-music-config--display-name-normal-url-label-from-map () + "Normal: a url track resolves to its #EXTINF label via the name-map." + (let ((track (test-display-name--url "https://ice6.somafm.com/groovesalad-256-mp3")) + (map '(("https://ice6.somafm.com/groovesalad-256-mp3" . "SomaFM Groove Salad")))) + (should (string= (cj/music--display-name track map) "SomaFM Groove Salad")))) + +;;; Normal -- url with tags formats like a tagged track + +(ert-deftest test-music-config--display-name-normal-url-with-tags () + "Normal: a url track carrying tags uses Artist - Title, not the URL." + (let ((track (test-display-name--url "https://tagged.example.com/stream" + "Jazz FM" "Radio Station"))) + (should (string= (cj/music--display-name track) "Radio Station - Jazz FM")))) + +;;; Boundary -- url with no label falls back to a tidied host + +(ert-deftest test-music-config--display-name-boundary-url-host-fallback () + "Boundary: a url with no label and no map falls back to the tidied host." + (let ((track (test-display-name--url "https://ice6.hostonly.somafm.com/gs"))) + (should (string= (cj/music--display-name track) "somafm.com")))) + +(ert-deftest test-music-config--display-name-boundary-url-not-in-map () + "Boundary: a url absent from a non-empty map still falls to the host." + (let ((track (test-display-name--url "https://stream.other.net/live")) + (map '(("https://ice6.somafm.com/x" . "Groove Salad")))) + (should (string= (cj/music--display-name track map) "other.net")))) + +(ert-deftest test-music-config--display-name-boundary-unicode-title () + "Boundary: unicode in the title is preserved." + (let ((track (test-display-name--file "/dn/unicode.mp3" "夜に駆ける" "YOASOBI" 258))) + (should (string= (cj/music--display-name track) "YOASOBI - 夜に駆ける")))) + +(ert-deftest test-music-config--display-name-boundary-file-multiple-dots () + "Boundary: only the final extension is stripped." + (let ((track (test-display-name--file "/dn/disc.1.track.03.flac"))) + (should (string= (cj/music--display-name track) "disc.1.track.03")))) + +;;; Error -- unknown type falls back without erroring + +(ert-deftest test-music-config--display-name-error-unknown-type () + "Error: an unknown track type falls back to a string, no error." + (let* ((track (emms-track 'streamlist "https://unknown.example.com/playlist.m3u")) + (result (cj/music--display-name track))) + (should (stringp result)) + (should (string-match-p "example\\.com" result)))) + +;;; format-meta + +(ert-deftest test-music-config--format-meta-normal-file-duration () + "Normal: a file with a duration yields the bracketed M:SS meta." + (let ((track (test-display-name--file "/dn/meta-dur.flac" "So What" "Miles" 562))) + (should (string= (cj/music--format-meta track) "[9:22]")))) + +(ert-deftest test-music-config--format-meta-boundary-no-duration () + "Boundary: a track with no duration yields an empty meta string." + (let ((track (test-display-name--file "/dn/meta-nodur.flac" "So What" "Miles"))) + (should (string= (cj/music--format-meta track) "")))) + +(ert-deftest test-music-config--format-meta-boundary-url-no-meta () + "Boundary: a url stream with no duration yields empty meta." + (let ((track (test-display-name--url "https://meta.example.com/stream"))) + (should (string= (cj/music--format-meta track) "")))) + +(provide 'test-music-config--display-name) +;;; test-music-config--display-name.el ends here diff --git a/tests/test-music-config--get-m3u-basenames.el b/tests/test-music-config--get-m3u-basenames.el index 91c8af70..1e3875df 100644 --- a/tests/test-music-config--get-m3u-basenames.el +++ b/tests/test-music-config--get-m3u-basenames.el @@ -9,7 +9,7 @@ ;; Test organization: ;; - Normal Cases: Multiple files, single file ;; - Boundary Cases: Empty directory, extension removal -;; - Error Cases: Nonexistent directory +;; - Error Cases: Nonexistent directory is skipped (not fatal) ;; ;;; Code: @@ -47,7 +47,7 @@ (rename-file file2 (expand-file-name "jazz.m3u" test-dir)) (rename-file file3 (expand-file-name "classical.m3u" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-basenames))) (should (= (length result) 3)) ;; Sort for consistent comparison @@ -63,7 +63,7 @@ (file1 (cj/create-temp-test-file-with-content "" "favorites.m3u"))) (rename-file file1 (expand-file-name "favorites.m3u" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-basenames))) (should (= (length result) 1)) (should (equal (car result) "favorites"))))) @@ -76,7 +76,7 @@ (test-music-config--get-m3u-basenames-setup) (unwind-protect (let* ((test-dir (cj/create-test-subdirectory "empty-playlists"))) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-basenames))) (should (null result))))) (test-music-config--get-m3u-basenames-teardown))) @@ -89,7 +89,7 @@ (file1 (cj/create-temp-test-file-with-content "" "test.m3u"))) (rename-file file1 (expand-file-name "playlist.m3u" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-basenames))) (should (equal result '("playlist"))) ;; Verify no .m3u extension present @@ -104,18 +104,17 @@ (file1 (cj/create-temp-test-file-with-content "" "test.m3u"))) (rename-file file1 (expand-file-name "My Favorite Songs.m3u" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-basenames))) (should (equal result '("My Favorite Songs")))))) (test-music-config--get-m3u-basenames-teardown))) ;;; Error Cases -(ert-deftest test-music-config--get-m3u-basenames-error-nonexistent-directory-signals-error () - "Nonexistent directory signals error." - (let ((cj/music-m3u-root "/nonexistent/directory/path")) - (should-error (cj/music--get-m3u-basenames) - :type 'file-error))) +(ert-deftest test-music-config--get-m3u-basenames-error-nonexistent-directory-skipped () + "Nonexistent directories in the roots list are skipped, returning empty." + (let ((cj/music-m3u-roots '("/nonexistent/directory/path"))) + (should-not (cj/music--get-m3u-basenames)))) (provide 'test-music-config--get-m3u-basenames) ;;; test-music-config--get-m3u-basenames.el ends here diff --git a/tests/test-music-config--get-m3u-files.el b/tests/test-music-config--get-m3u-files.el index 2d31d554..356735a9 100644 --- a/tests/test-music-config--get-m3u-files.el +++ b/tests/test-music-config--get-m3u-files.el @@ -4,12 +4,12 @@ ;; ;;; Commentary: ;; Unit tests for cj/music--get-m3u-files function. -;; Tests the helper that discovers M3U files in the music directory. +;; Tests the helper that discovers M3U files across cj/music-m3u-roots. ;; ;; Test organization: ;; - Normal Cases: Multiple M3U files, single file ;; - Boundary Cases: Empty directory, non-M3U files, various filenames -;; - Error Cases: Nonexistent directory +;; - Error Cases: Nonexistent directory is skipped (not fatal) ;; ;;; Code: @@ -48,7 +48,7 @@ (rename-file file2 (expand-file-name "playlist2.m3u" test-dir)) (rename-file file3 (expand-file-name "playlist3.m3u" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-files))) (should (= (length result) 3)) ;; Check structure: list of (basename . fullpath) conses @@ -70,7 +70,7 @@ (file1 (cj/create-temp-test-file-with-content "" "myplaylist.m3u"))) (rename-file file1 (expand-file-name "myplaylist.m3u" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-files))) (should (= (length result) 1)) (should (equal (caar result) "myplaylist.m3u")) @@ -84,7 +84,7 @@ (test-music-config--get-m3u-files-setup) (unwind-protect (let* ((test-dir (cj/create-test-subdirectory "empty-playlists"))) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-files))) (should (null result))))) (test-music-config--get-m3u-files-teardown))) @@ -101,7 +101,7 @@ (rename-file mp3-file (expand-file-name "song.mp3" test-dir)) (rename-file json-file (expand-file-name "data.json" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-files))) (should (null result))))) (test-music-config--get-m3u-files-teardown))) @@ -114,7 +114,7 @@ (file1 (cj/create-temp-test-file-with-content "" "my-playlist.m3u"))) (rename-file file1 (expand-file-name "My Favorite Songs.m3u" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-files))) (should (= (length result) 1)) (should (equal (caar result) "My Favorite Songs.m3u"))))) @@ -132,7 +132,7 @@ (rename-file txt-file (expand-file-name "readme.txt" test-dir)) (rename-file mp3-file (expand-file-name "song.mp3" test-dir)) - (let ((cj/music-m3u-root test-dir)) + (let ((cj/music-m3u-roots (list test-dir))) (let ((result (cj/music--get-m3u-files))) (should (= (length result) 1)) (should (equal (caar result) "playlist.m3u"))))) @@ -140,11 +140,10 @@ ;;; Error Cases -(ert-deftest test-music-config--get-m3u-files-error-nonexistent-directory-signals-error () - "Nonexistent directory signals error." - (let ((cj/music-m3u-root "/nonexistent/directory/path")) - (should-error (cj/music--get-m3u-files) - :type 'file-error))) +(ert-deftest test-music-config--get-m3u-files-error-nonexistent-directory-skipped () + "Nonexistent directories in the roots list are skipped, returning empty." + (let ((cj/music-m3u-roots '("/nonexistent/directory/path"))) + (should-not (cj/music--get-m3u-files)))) (provide 'test-music-config--get-m3u-files) ;;; test-music-config--get-m3u-files.el ends here diff --git a/tests/test-music-config--m3u-entries.el b/tests/test-music-config--m3u-entries.el new file mode 100644 index 00000000..1eaf1345 --- /dev/null +++ b/tests/test-music-config--m3u-entries.el @@ -0,0 +1,67 @@ +;;; test-music-config--m3u-entries.el --- Tests for #EXTINF/UUID/favicon parse -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--m3u-entries': parse .m3u text into an alist of +;; (stream-url . plist), each plist carrying :name (the #EXTINF label), :uuid +;; (#RADIOBROWSERUUID), and :favicon (#RADIOBROWSERFAVICON). This is the one +;; pure parser both the name resolution (Phase 1) and the cover-art layer read. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +(ert-deftest test-music-config--m3u-entries-normal-name-only () + "Normal: an #EXTINF + url pair yields :name with nil :uuid and :favicon." + (let* ((text "#EXTM3U\n#EXTINF:1,SomaFM Groove Salad\nhttps://ice6.somafm.com/gs\n") + (e (cdr (assoc "https://ice6.somafm.com/gs" (cj/music--m3u-entries text))))) + (should (equal (plist-get e :name) "SomaFM Groove Salad")) + (should (null (plist-get e :uuid))) + (should (null (plist-get e :favicon))))) + +(ert-deftest test-music-config--m3u-entries-normal-uuid-and-favicon () + "Normal: UUID and favicon comment lines are captured onto the entry." + (let* ((text (concat "#EXTM3U\n#EXTINF:1,Jazz24\n" + "#RADIOBROWSERUUID:abc-123\n" + "#RADIOBROWSERFAVICON:https://cdn.example/jazz.png\n" + "https://jazz.example/live\n")) + (e (cdr (assoc "https://jazz.example/live" (cj/music--m3u-entries text))))) + (should (equal (plist-get e :name) "Jazz24")) + (should (equal (plist-get e :uuid) "abc-123")) + (should (equal (plist-get e :favicon) "https://cdn.example/jazz.png")))) + +(ert-deftest test-music-config--m3u-entries-normal-multiple-reset () + "Normal: fields reset between stations (station B has no UUID leak from A)." + (let* ((text (concat "#EXTINF:1,A\n#RADIOBROWSERUUID:aaa\nhttps://a.example/1\n" + "#EXTINF:1,B\nhttps://b.example/2\n")) + (entries (cj/music--m3u-entries text)) + (b (cdr (assoc "https://b.example/2" entries)))) + (should (equal (plist-get b :name) "B")) + (should (null (plist-get b :uuid))))) + +(ert-deftest test-music-config--m3u-entries-boundary-url-without-extinf () + "Boundary: a bare url with no #EXTINF is skipped." + (should (null (cj/music--m3u-entries "#EXTM3U\nhttps://plain.example/stream\n")))) + +(ert-deftest test-music-config--m3u-entries-boundary-empty () + "Boundary: empty text yields nil." + (should (null (cj/music--m3u-entries "")))) + +(ert-deftest test-music-config--m3u-entries-boundary-comma-in-name () + "Boundary: a comma inside the #EXTINF label is preserved." + (let* ((text "#EXTINF:1,Radio, the Good Kind\nhttps://x.example/s\n") + (e (cdr (assoc "https://x.example/s" (cj/music--m3u-entries text))))) + (should (equal (plist-get e :name) "Radio, the Good Kind")))) + +(provide 'test-music-config--m3u-entries) +;;; test-music-config--m3u-entries.el ends here 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--m3u-labels.el b/tests/test-music-config--m3u-labels.el new file mode 100644 index 00000000..02f328cd --- /dev/null +++ b/tests/test-music-config--m3u-labels.el @@ -0,0 +1,62 @@ +;;; test-music-config--m3u-labels.el --- Tests for #EXTINF label extraction -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--m3u-labels': parse .m3u text into an alist of +;; (stream-url . #EXTINF-label) pairs. This is the pure core that lets a url +;; track resolve to its station name (the label written at creation) instead +;; of the raw stream URL. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +(ert-deftest test-music-config--m3u-labels-normal-single () + "Normal: one #EXTINF + url pair yields one (url . label) cons." + (let ((text "#EXTM3U\n#EXTINF:1,SomaFM Groove Salad\nhttps://ice6.somafm.com/gs\n")) + (should (equal (cj/music--m3u-labels text) + '(("https://ice6.somafm.com/gs" . "SomaFM Groove Salad")))))) + +(ert-deftest test-music-config--m3u-labels-normal-uuid-line-between () + "Normal: a #RADIOBROWSERUUID line between #EXTINF and the url is skipped." + (let ((text (concat "#EXTM3U\n#EXTINF:1,Jazz24\n" + "#RADIOBROWSERUUID:abc-123\nhttps://jazz.example/live\n"))) + (should (equal (cj/music--m3u-labels text) + '(("https://jazz.example/live" . "Jazz24")))))) + +(ert-deftest test-music-config--m3u-labels-normal-multiple () + "Normal: multiple stations each yield their own pair." + (let ((text (concat "#EXTM3U\n" + "#EXTINF:1,Station A\nhttps://a.example/1\n" + "#EXTINF:-1,Station B\nhttps://b.example/2\n"))) + (should (equal (cj/music--m3u-labels text) + '(("https://a.example/1" . "Station A") + ("https://b.example/2" . "Station B")))))) + +(ert-deftest test-music-config--m3u-labels-boundary-url-without-extinf () + "Boundary: a bare url with no preceding #EXTINF produces no pair." + (let ((text "#EXTM3U\nhttps://plain.example/stream\n")) + (should (null (cj/music--m3u-labels text))))) + +(ert-deftest test-music-config--m3u-labels-boundary-empty () + "Boundary: empty text yields nil." + (should (null (cj/music--m3u-labels "")))) + +(ert-deftest test-music-config--m3u-labels-boundary-comma-in-name () + "Boundary: a comma inside the label is preserved (split on the first only)." + (let ((text "#EXTINF:1,Radio, the Good Kind\nhttps://x.example/s\n")) + (should (equal (cj/music--m3u-labels text) + '(("https://x.example/s" . "Radio, the Good Kind")))))) + +(provide 'test-music-config--m3u-labels) +;;; test-music-config--m3u-labels.el ends here diff --git a/tests/test-music-config--m3u-roots.el b/tests/test-music-config--m3u-roots.el new file mode 100644 index 00000000..626415b6 --- /dev/null +++ b/tests/test-music-config--m3u-roots.el @@ -0,0 +1,97 @@ +;;; test-music-config--m3u-roots.el --- multi-directory M3U sourcing tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The player sources .m3u playlists from a LIST of directories +;; (`cj/music-m3u-roots') so the local-library playlists (~/music) and the +;; dotfiles-tracked internet-radio playlists (MPD's playlist_directory) surface +;; together for selection and loading. Two pieces are tested: +;; +;; - `cj/music--dedup-m3u-files' — pure: turns a flat list of paths into +;; (BASENAME . PATH) conses, first occurrence of a basename winning. +;; - `cj/music--get-m3u-files' — unions the roots on disk, skips missing dirs, +;; and applies the dedup so an earlier root shadows a same-named later one. +;; +;;; Code: + +(require 'ert) + +;; Stub missing dependencies before loading music-config. +(defvar-keymap cj/custom-keymap + :doc "Stub keymap for testing") + +(require 'music-config) + +(declare-function cj/music--dedup-m3u-files "music-config" (paths)) +(declare-function cj/music--get-m3u-files "music-config" ()) +(defvar cj/music-m3u-roots) + +;;; --------------------------- cj/music--dedup-m3u-files ---------------------- + +(ert-deftest test-music-config-dedup-m3u-distinct () + "Normal: distinct basenames across dirs all appear, in order." + (should (equal (cj/music--dedup-m3u-files + '("/music/rhcp.m3u" "/radio/90s Sounds.m3u")) + '(("rhcp.m3u" . "/music/rhcp.m3u") + ("90s Sounds.m3u" . "/radio/90s Sounds.m3u"))))) + +(ert-deftest test-music-config-dedup-m3u-single () + "Normal: a single path yields a single cons." + (should (equal (cj/music--dedup-m3u-files '("/music/blues.m3u")) + '(("blues.m3u" . "/music/blues.m3u"))))) + +(ert-deftest test-music-config-dedup-m3u-collision-first-wins () + "Boundary: a basename in two dirs keeps the first path (earlier root wins)." + (should (equal (cj/music--dedup-m3u-files + '("/music/jazz.m3u" "/radio/jazz.m3u")) + '(("jazz.m3u" . "/music/jazz.m3u"))))) + +(ert-deftest test-music-config-dedup-m3u-empty () + "Boundary: an empty path list yields nil." + (should-not (cj/music--dedup-m3u-files '()))) + +;;; ---------------------------- cj/music--get-m3u-files ----------------------- + +(ert-deftest test-music-config-get-m3u-unions-roots () + "Normal: M3Us from every existing root are unioned." + (let ((a (make-temp-file "m3u-a-" t)) + (b (make-temp-file "m3u-b-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "local.m3u" a)) + (write-region "" nil (expand-file-name "radio.m3u" b)) + (let* ((cj/music-m3u-roots (list a b)) + (bases (mapcar #'car (cj/music--get-m3u-files)))) + (should (member "local.m3u" bases)) + (should (member "radio.m3u" bases)))) + (delete-directory a t) + (delete-directory b t)))) + +(ert-deftest test-music-config-get-m3u-skips-missing-root () + "Error: a non-existent directory in the list is skipped, not fatal." + (let ((a (make-temp-file "m3u-a-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "local.m3u" a)) + (let* ((cj/music-m3u-roots (list a "/no/such/dir/here")) + (bases (mapcar #'car (cj/music--get-m3u-files)))) + (should (equal bases '("local.m3u"))))) + (delete-directory a t)))) + +(ert-deftest test-music-config-get-m3u-collision-first-root-wins () + "Boundary: same basename in two roots resolves to the earlier root's file." + (let ((a (make-temp-file "m3u-a-" t)) + (b (make-temp-file "m3u-b-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "jazz.m3u" a)) + (write-region "" nil (expand-file-name "jazz.m3u" b)) + (let* ((cj/music-m3u-roots (list a b)) + (pair (assoc "jazz.m3u" (cj/music--get-m3u-files)))) + (should (string-prefix-p a (cdr pair))))) + (delete-directory a t) + (delete-directory b t)))) + +(provide 'test-music-config--m3u-roots) +;;; test-music-config--m3u-roots.el ends here diff --git a/tests/test-music-config--m3u-text.el b/tests/test-music-config--m3u-text.el new file mode 100644 index 00000000..14c9f2bf --- /dev/null +++ b/tests/test-music-config--m3u-text.el @@ -0,0 +1,93 @@ +;;; test-music-config--m3u-text.el --- playlist .m3u emitter tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The custom .m3u emitter behind playlist save. The stock EMMS m3u writer +;; emits bare URLs, which would throw away a station's name/uuid/favicon on +;; save; this emitter writes the same #EXTINF / #RADIOBROWSERUUID / +;; #RADIOBROWSERFAVICON lines the parser (`cj/music--m3u-entries') reads, so +;; save -> load round-trips a station's display name and cover-art metadata. +;; Metadata comes from track properties first, the m3u-scan entries as +;; fallback (a loaded legacy playlist has entries but no properties). + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for 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) + +(declare-function cj/music--m3u-text "music-config" (tracks entries)) +(declare-function cj/music-radio--station-track "music-config" (st)) + +(ert-deftest test-music-m3u-text-normal-file-track-bare-path () + "Normal: a file track is a bare absolute path under the #EXTM3U header." + (let ((text (cj/music--m3u-text (list (emms-track 'file "/music/a.flac")) nil))) + (should (string-prefix-p "#EXTM3U\n" text)) + (should (string-match-p "^/music/a\\.flac$" text)))) + +(ert-deftest test-music-m3u-text-normal-url-track-from-properties () + "Normal: a url track with properties emits uuid, favicon, EXTINF, and url." + (let* ((track (cj/music-radio--station-track + '(:name "Groove Salad" :url "https://ck.somafm.com/gs" + :stationuuid "uuid-1" :favicon "https://somafm.com/i.png"))) + (text (cj/music--m3u-text (list track) nil))) + (should (string-match-p "^#RADIOBROWSERUUID:uuid-1$" text)) + (should (string-match-p "^#RADIOBROWSERFAVICON:https://somafm\\.com/i\\.png$" text)) + (should (string-match-p "^#EXTINF:-1,Groove Salad$" text)) + (should (string-match-p "^https://ck\\.somafm\\.com/gs$" text)))) + +(ert-deftest test-music-m3u-text-normal-url-track-from-entries-fallback () + "Normal: a propertyless url track (a loaded legacy playlist) resolves its +metadata from the ENTRIES alist." + (let* ((url "https://legacy.example/stream") + (track (emms-track 'url url)) + (entries (list (list url :name "Legacy FM" :uuid "uuid-9" + :favicon "https://legacy.example/f.ico"))) + (text (cj/music--m3u-text (list track) entries))) + (should (string-match-p "^#RADIOBROWSERUUID:uuid-9$" text)) + (should (string-match-p "^#EXTINF:-1,Legacy FM$" text)))) + +(ert-deftest test-music-m3u-text-boundary-url-track-no-metadata () + "Boundary: a url track with neither properties nor entries still gets an +EXTINF label (the tidied host) and no uuid/favicon lines." + (let ((text (cj/music--m3u-text + (list (emms-track 'url "https://ice6.somafm.com/live")) nil))) + (should (string-match-p "^#EXTINF:-1,somafm\\.com$" text)) + (should-not (string-match-p "RADIOBROWSERUUID" text)) + (should-not (string-match-p "RADIOBROWSERFAVICON" text)))) + +(ert-deftest test-music-m3u-text-normal-mixed-order-preserved () + "Normal: a mixed queue keeps its track order in the file." + (let* ((f (emms-track 'file "/music/b.mp3")) + (u (cj/music-radio--station-track '(:name "S" :url "https://s.example/x"))) + (text (cj/music--m3u-text (list f u) nil))) + (should (< (string-match "^/music/b\\.mp3$" text) + (string-match "^https://s\\.example/x$" text))))) + +(ert-deftest test-music-m3u-text-round-trip-through-parser () + "Normal: the parser recovers name, uuid, and favicon from emitted text." + (let* ((track (cj/music-radio--station-track + '(:name "Round Trip" :url "https://rt.example/s" + :stationuuid "uuid-rt" :favicon "https://rt.example/f.png"))) + (entries (cj/music--m3u-entries (cj/music--m3u-text (list track) nil))) + (meta (cdr (assoc "https://rt.example/s" entries)))) + (should (equal (plist-get meta :name) "Round Trip")) + (should (equal (plist-get meta :uuid) "uuid-rt")) + (should (equal (plist-get meta :favicon) "https://rt.example/f.png")))) + +(ert-deftest test-music-m3u-text-boundary-empty-playlist-header-only () + "Boundary: an empty track list is just the #EXTM3U header." + (should (equal (cj/music--m3u-text nil nil) "#EXTM3U\n"))) + +(provide 'test-music-config--m3u-text) +;;; test-music-config--m3u-text.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 new file mode 100644 index 00000000..1dbe9fbb --- /dev/null +++ b/tests/test-music-config--playlist-dock.el @@ -0,0 +1,114 @@ +;;; test-music-config--playlist-dock.el --- Tests for the F10 playlist dock -*- lexical-binding: t; -*- + +;;; Commentary: +;; The F10 playlist always docks at the bottom, whatever the frame's shape. +;; It used to pick `right' on a wide frame via `cj/preferred-dock-direction', +;; which produced an unwanted three-way split on a wide terminal. +;; +;; `cj/side-window-display' is the window-system boundary here, so it is the +;; thing stubbed (an ordinary defun -- safe to `cl-letf', unlike the frame-* +;; subrs). Stubbing it lets these tests assert what the toggle *asks for* +;; without needing a live frame under `--batch'. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'music-config) + +(defmacro test-music-dock--with-captured-side (captured &rest body) + "Run BODY with the playlist display path stubbed, recording its args in CAPTURED. +CAPTURED is set to a plist of :side, :size-var and :default-size." + (declare (indent 1)) + `(let ((buffer (generate-new-buffer " *test-playlist*"))) + (unwind-protect + (cl-letf (((symbol-function 'cj/emms--setup) (lambda (&rest _) nil)) + ((symbol-function 'cj/music--ensure-playlist-buffer) + (lambda (&rest _) buffer)) + ((symbol-function 'emms-playlist-mode-center-current) + (lambda (&rest _) nil)) + ((symbol-function 'cj/side-window-display) + (lambda (_buf side size-var default-size) + (setq ,captured (list :side side :size-var size-var + :default-size default-size)) + (selected-window)))) + ,@body) + (kill-buffer buffer)))) + +(ert-deftest test-music-config-playlist-toggle-docks-bottom-on-wide-frame () + "Normal: a wide frame still docks the playlist at the bottom. +A wide frame used to dock right, splitting the frame three ways." + (let (captured) + (test-music-dock--with-captured-side captured + (cl-letf (((symbol-function 'frame-width) (lambda (&rest _) 400))) + (cj/music-playlist-toggle))) + (should (eq 'bottom (plist-get captured :side))))) + +(ert-deftest test-music-config-playlist-toggle-docks-bottom-on-narrow-frame () + "Boundary: a narrow frame docks at the bottom, as it always did." + (let (captured) + (test-music-dock--with-captured-side captured + (cl-letf (((symbol-function 'frame-width) (lambda (&rest _) 40))) + (cj/music-playlist-toggle))) + (should (eq 'bottom (plist-get captured :side))))) + +(ert-deftest test-music-config-playlist-toggle-uses-height-memory () + "Normal: the bottom dock carries the height fraction and its memory var." + (let (captured) + (test-music-dock--with-captured-side captured + (cj/music-playlist-toggle)) + (should (eq 'cj/--music-playlist-height (plist-get captured :size-var))) + (should (= cj/music-playlist-window-height (plist-get captured :default-size))))) + +(ert-deftest test-music-config-playlist-dock-has-no-width-knobs () + "Error: the right-dock width variables are gone, not merely unused. +A stale `cj/music-playlist-window-width' would read as a live knob that +silently does nothing." + (should-not (boundp 'cj/music-playlist-window-width)) + (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--playlist-side.el b/tests/test-music-config--playlist-side.el deleted file mode 100644 index f4969469..00000000 --- a/tests/test-music-config--playlist-side.el +++ /dev/null @@ -1,45 +0,0 @@ -;;; test-music-config--playlist-side.el --- Tests for the F10 dock-side helper -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/--music-playlist-side' maps the shared dock rule's verdict to a -;; `display-buffer-in-side-window' side: `right' stays `right', anything -;; else becomes `bottom'. The decision itself lives in -;; `cj/preferred-dock-direction' (tested in test-cj-window-geometry-lib.el); -;; here we stub it (an ordinary defun -- safe to `cl-letf', unlike the -;; frame-* subrs) to prove the mapping and that the width fraction is -;; passed through. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'music-config) - -(ert-deftest test-music-config--playlist-side-right-verdict-is-right () - "Normal: a `right' verdict from the dock rule docks the playlist right." - (cl-letf (((symbol-function 'cj/preferred-dock-direction) - (lambda (&rest _) 'right))) - (should (eq (cj/--music-playlist-side) 'right)))) - -(ert-deftest test-music-config--playlist-side-below-verdict-is-bottom () - "Normal: a `below' verdict maps to the `bottom' side window." - (cl-letf (((symbol-function 'cj/preferred-dock-direction) - (lambda (&rest _) 'below))) - (should (eq (cj/--music-playlist-side) 'bottom)))) - -(ert-deftest test-music-config--playlist-side-passes-width-fraction () - "Normal: the playlist's width fraction reaches the dock rule." - (let ((cj/music-playlist-window-width 0.4) - captured) - (cl-letf (((symbol-function 'cj/preferred-dock-direction) - (lambda (cols frac &rest _) - (setq captured (list cols frac)) - 'below))) - (cj/--music-playlist-side) - (should (= (nth 1 captured) 0.4)) - (should (integerp (nth 0 captured)))))) - -(provide 'test-music-config--playlist-side) -;;; test-music-config--playlist-side.el ends here diff --git a/tests/test-music-config--radio-station-track.el b/tests/test-music-config--radio-station-track.el new file mode 100644 index 00000000..5816c776 --- /dev/null +++ b/tests/test-music-config--radio-station-track.el @@ -0,0 +1,135 @@ +;;; test-music-config--radio-station-track.el --- station->track + enqueue tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The queue-first radio model: a picked station becomes an EMMS url track +;; carrying its metadata as track properties (info-title, radio-uuid, +;; radio-favicon) instead of being written to an .m3u. Covers the pure +;; station->track builder and the enqueue-and-play buffer mechanics (with +;; playback mocked at the EMMS boundary). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for 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) + +(declare-function cj/music-radio--station-track "music-config" (st)) +(declare-function cj/music-radio--enqueue-and-play "music-config" (tracks)) + +;;; --------------------------- station-track ----------------------------------- + +(ert-deftest test-music-radio-station-track-normal () + "Normal: a full station plist yields a url track with all three properties." + (let ((track (cj/music-radio--station-track + '(:name "Adroit Jazz Underground" + :url_resolved "https://icecast.walmradio.com:8443/jazz" + :stationuuid "ea8059be-d119" + :favicon "https://walmradio.com/icon.png")))) + (should (eq (emms-track-type track) 'url)) + (should (equal (emms-track-name track) "https://icecast.walmradio.com:8443/jazz")) + (should (equal (emms-track-get track 'info-title) "Adroit Jazz Underground")) + (should (equal (emms-track-get track 'radio-uuid) "ea8059be-d119")) + (should (equal (emms-track-get track 'radio-favicon) "https://walmradio.com/icon.png")))) + +(ert-deftest test-music-radio-station-track-no-url-is-nil () + "Error: a station with no stream URL yields nil, not a broken track." + (should-not (cj/music-radio--station-track '(:name "No URL" :url_resolved "" :url "")))) + +(ert-deftest test-music-radio-station-track-boundary-no-name () + "Boundary: a nameless station falls back to \"Radio\" for its title." + (let ((track (cj/music-radio--station-track '(:url "https://s.example/live")))) + (should (equal (emms-track-get track 'info-title) "Radio")))) + +(ert-deftest test-music-radio-station-track-boundary-newline-name-stripped () + "Boundary: newlines in an external station name are flattened to spaces." + (let ((track (cj/music-radio--station-track + '(:name "Line\nBreak" :url "https://s.example/live")))) + (should (equal (emms-track-get track 'info-title) "Line Break")))) + +(ert-deftest test-music-radio-station-track-boundary-empty-uuid-favicon-absent () + "Boundary: empty-string uuid/favicon are treated as absent, not stored." + (let ((track (cj/music-radio--station-track + '(:name "X" :url "https://s.example/live" :stationuuid "" :favicon "")))) + (should-not (emms-track-get track 'radio-uuid)) + (should-not (emms-track-get track 'radio-favicon)))) + +;;; ------------------------- enqueue-and-play ---------------------------------- + +(defmacro test-music-radio--with-playlist (&rest body) + "Run BODY with a fresh, uniquely named playlist buffer and playback mocked." + `(let* ((cj/music-playlist-buffer-name + (generate-new-buffer-name "*test-radio-enqueue*")) + (emms-player-playing-p nil) + (started 0) (stopped 0)) + (unwind-protect + (cl-letf (((symbol-function 'emms-start) + (lambda () (setq started (1+ started)))) + ((symbol-function 'emms-stop) + (lambda () (setq stopped (1+ stopped))))) + ,@body) + (when (get-buffer cj/music-playlist-buffer-name) + (kill-buffer cj/music-playlist-buffer-name))))) + +(ert-deftest test-music-radio-enqueue-and-play-normal-appends-and-plays () + "Normal: tracks land in the playlist buffer in order; the first is selected +and playback starts." + (test-music-radio--with-playlist + (let ((t1 (cj/music-radio--station-track '(:name "One" :url "https://one.example/a"))) + (t2 (cj/music-radio--station-track '(:name "Two" :url "https://two.example/b")))) + (cj/music-radio--enqueue-and-play (list t1 t2)) + (with-current-buffer cj/music-playlist-buffer-name + (let ((names '())) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when-let ((tr (emms-playlist-track-at (point)))) + (push (emms-track-name tr) names)) + (forward-line 1))) + (should (equal (nreverse names) + '("https://one.example/a" "https://two.example/b")))) + (should (equal (emms-track-name (emms-playlist-selected-track)) + "https://one.example/a"))) + (should (= started 1))))) + +(ert-deftest test-music-radio-enqueue-and-play-boundary-appends-after-existing () + "Boundary: an existing queue is kept; new tracks append and the first NEW +track is the one selected." + (test-music-radio--with-playlist + (let ((old (cj/music-radio--station-track '(:name "Old" :url "https://old.example/x"))) + (new (cj/music-radio--station-track '(:name "New" :url "https://new.example/y")))) + (cj/music-radio--enqueue-and-play (list old)) + (cj/music-radio--enqueue-and-play (list new)) + (with-current-buffer cj/music-playlist-buffer-name + (should (equal (emms-track-name (emms-playlist-selected-track)) + "https://new.example/y")))))) + +(ert-deftest test-music-radio-enqueue-and-play-interrupts-current-playback () + "Normal: when something is playing, enqueue stops it before starting." + (test-music-radio--with-playlist + (let ((emms-player-playing-p t) + (tr (cj/music-radio--station-track '(:name "Z" :url "https://z.example/s")))) + (cj/music-radio--enqueue-and-play (list tr)) + (should (= stopped 1)) + (should (= started 1))))) + +(ert-deftest test-music-radio-enqueue-and-play-boundary-nil-is-no-op () + "Boundary: an empty track list does nothing — no buffer churn, no playback." + (test-music-radio--with-playlist + (cj/music-radio--enqueue-and-play nil) + (should (= started 0)) + (should (= stopped 0)))) + +(provide 'test-music-config--radio-station-track) +;;; test-music-config--radio-station-track.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 new file mode 100644 index 00000000..a91612bf --- /dev/null +++ b/tests/test-music-config--radio.el @@ -0,0 +1,207 @@ +;;; test-music-config--radio.el --- radio-browser lookup pure-logic tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The pure pieces behind the radio-browser search command (spec +;; docs/specs/2026-07-06-radio-browser-lookup-spec.org): parsing a recorded +;; JSON response, picking a station's stream URL, formatting the marginalia +;; annotation (Variant B: codec/bitrate/country/votes/tags), and building the +;; search URL. The station->track builder and the queue mechanics live in +;; test-music-config--radio-station-track.el; the network GET and the +;; interactive command are exercised in the daemon, not here. + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(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)) +(declare-function cj/music-radio--station-url "music-config" (st)) +(declare-function cj/music-radio--tags-snippet "music-config" (tags n)) +(declare-function cj/music-radio--format-candidate "music-config" (st)) +(declare-function cj/music-radio--search-url "music-config" (server query)) + +(defconst test-music-radio--fixture + (concat "[{\"stationuuid\":\"ea8059be-d119-4de3-b27b-0d9bd6aedb17\"," + "\"name\":\"Adroit Jazz Underground\",\"url_resolved\":\"https://icecast.walmradio.com:8443/jazz\"," + "\"codec\":\"MP3\",\"bitrate\":320,\"countrycode\":\"US\",\"votes\":174208,\"tags\":\"bebop,hard bop,cool\"}," + "{\"stationuuid\":\"00000000-no-url\",\"name\":\"No URL Station\",\"url_resolved\":\"\",\"url\":\"\"," + "\"codec\":\"AAC\",\"bitrate\":0,\"countrycode\":\"FR\",\"votes\":5,\"tags\":\"\"}]") + "A two-station recorded radio-browser search response.") + +(defun test-music-radio--first () + "First station plist from the fixture." + (car (cj/music-radio--parse-search test-music-radio--fixture))) + +;;; --------------------------- parse-search ----------------------------------- + +(ert-deftest test-music-radio-parse-search-normal () + "Normal: a recorded response parses to station plists with the expected fields." + (let ((stations (cj/music-radio--parse-search test-music-radio--fixture))) + (should (= (length stations) 2)) + (should (equal (plist-get (car stations) :name) "Adroit Jazz Underground")) + (should (equal (plist-get (car stations) :stationuuid) + "ea8059be-d119-4de3-b27b-0d9bd6aedb17")))) + +(ert-deftest test-music-radio-parse-search-empty () + "Boundary: an empty result array parses to nil." + (should-not (cj/music-radio--parse-search "[]"))) + +(ert-deftest test-music-radio-parse-search-malformed-user-errors () + "Error: a non-JSON body (a gateway page) signals user-error, not a raw parse error." + (should-error (cj/music-radio--parse-search "<html>502 Bad Gateway</html>") + :type 'user-error)) + +;;; --------------------------- station-url ------------------------------------ + +(ert-deftest test-music-radio-station-url-resolved () + "Normal: url_resolved wins when present." + (should (equal (cj/music-radio--station-url (test-music-radio--first)) + "https://icecast.walmradio.com:8443/jazz"))) + +(ert-deftest test-music-radio-station-url-fallback-to-url () + "Boundary: an empty url_resolved falls back to url." + (should (equal (cj/music-radio--station-url + '(:url_resolved "" :url "http://fallback.test/stream")) + "http://fallback.test/stream"))) + +(ert-deftest test-music-radio-station-url-none () + "Error: neither url_resolved nor url yields nil." + (should-not (cj/music-radio--station-url '(:url_resolved "" :url "")))) + +;;; --------------------------- tags-snippet ----------------------------------- + +(ert-deftest test-music-radio-tags-snippet-takes-first-n () + "Normal: the first N comma-separated tags render trimmed." + (should (equal (cj/music-radio--tags-snippet "bebop, hard bop, cool, free jazz" 3) + "bebop, hard bop, cool"))) + +(ert-deftest test-music-radio-tags-snippet-empty () + "Boundary: empty or nil tags render as the empty string." + (should (equal (cj/music-radio--tags-snippet "" 3) "")) + (should (equal (cj/music-radio--tags-snippet nil 3) ""))) + +;;; --------------------------- format-candidate (Variant B) ------------------- + +(ert-deftest test-music-radio-format-candidate-variant-b () + "Normal: the annotation carries codec, votes, and tags (Variant B)." + (let ((ann (cj/music-radio--format-candidate (test-music-radio--first)))) + (should (string-match-p "MP3" ann)) + (should (string-match-p "174208" ann)) + (should (string-match-p "bebop" ann)))) + +;;; --------------------------- search-url ------------------------------------- + +(ert-deftest test-music-radio-search-url-encodes-query-and-limit () + "Normal: the search URL hex-encodes the query and carries the limit; name is the default field." + (let* ((cj/music-radio-search-limit 30) + (u (cj/music-radio--search-url "de1.api.radio-browser.info" "smooth jazz"))) + (should (string-match-p "name=smooth%20jazz" u)) + (should (string-match-p "limit=30" u)) + (should (string-match-p "/json/stations/search" u)))) + +(ert-deftest test-music-radio-search-url-tag-field () + "Normal: field \"tag\" searches the tag= parameter instead of name=." + (let ((u (cj/music-radio--search-url "de1.api.radio-browser.info" "ambient" "tag"))) + (should (string-match-p "tag=ambient" u)) + (should-not (string-match-p "name=ambient" u)))) + +(declare-function cj/music-radio--candidates "music-config" (stations)) + +;;; --------------------------- candidates (dedup) ----------------------------- + +(ert-deftest test-music-radio-candidates-distinct () + "Normal: distinct station names produce distinct display keys mapping to their stations." + (let* ((stations '((:name "Jazz Radio" :codec "MP3" :bitrate 128) + (:name "Blues FM" :codec "AAC" :bitrate 64))) + (cands (cj/music-radio--candidates stations))) + (should (= (length cands) 2)) + (should (assoc "Jazz Radio" cands)) + (should (assoc "Blues FM" cands)))) + +(ert-deftest test-music-radio-candidates-same-name-disambiguated () + "Boundary: two stations with the same name get distinct display keys." + (let* ((stations '((:name "Jazz Radio" :codec "MP3" :bitrate 128 :stationuuid "a") + (:name "Jazz Radio" :codec "OGG" :bitrate 192 :stationuuid "b"))) + (cands (cj/music-radio--candidates stations)) + (keys (mapcar #'car cands))) + (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--safe-filename.el b/tests/test-music-config--safe-filename.el deleted file mode 100644 index 8105ee15..00000000 --- a/tests/test-music-config--safe-filename.el +++ /dev/null @@ -1,97 +0,0 @@ -;;; test-music-config--safe-filename.el --- Tests for filename sanitization -*- coding: utf-8; lexical-binding: t; -*- -;; -;; Author: Craig Jennings <c@cjennings.net> -;; -;;; Commentary: -;; Unit tests for cj/music--safe-filename function. -;; Tests the pure helper that sanitizes filenames by replacing invalid chars. -;; -;; Test organization: -;; - Normal Cases: Valid filenames unchanged, spaces replaced -;; - Boundary Cases: Special chars, unicode, slashes, consecutive invalid chars -;; - Error Cases: Nil input -;; -;;; Code: - -(require 'ert) - -;; Stub missing dependencies before loading music-config -(defvar-keymap cj/custom-keymap - :doc "Stub keymap for testing") - -;; Load production code -(require 'music-config) - -;;; Normal Cases - -(ert-deftest test-music-config--safe-filename-normal-alphanumeric-unchanged () - "Validate alphanumeric filename remains unchanged." - (should (string= (cj/music--safe-filename "MyPlaylist123") - "MyPlaylist123"))) - -(ert-deftest test-music-config--safe-filename-normal-with-hyphens-unchanged () - "Validate filename with hyphens remains unchanged." - (should (string= (cj/music--safe-filename "my-playlist-name") - "my-playlist-name"))) - -(ert-deftest test-music-config--safe-filename-normal-with-underscores-unchanged () - "Validate filename with underscores remains unchanged." - (should (string= (cj/music--safe-filename "my_playlist_name") - "my_playlist_name"))) - -(ert-deftest test-music-config--safe-filename-normal-spaces-replaced () - "Validate spaces are replaced with underscores." - (should (string= (cj/music--safe-filename "My Favorite Songs") - "My_Favorite_Songs"))) - -;;; Boundary Cases - -(ert-deftest test-music-config--safe-filename-boundary-special-chars-replaced () - "Validate special characters are replaced with underscores." - (should (string= (cj/music--safe-filename "playlist@#$%^&*()") - "playlist_________"))) - -(ert-deftest test-music-config--safe-filename-boundary-unicode-replaced () - "Validate unicode characters are replaced with underscores." - (should (string= (cj/music--safe-filename "中文歌曲") - "____"))) - -(ert-deftest test-music-config--safe-filename-boundary-mixed-valid-invalid () - "Validate mixed valid and invalid characters." - (should (string= (cj/music--safe-filename "Rock & Roll") - "Rock___Roll"))) - -(ert-deftest test-music-config--safe-filename-boundary-dots-replaced () - "Validate dots are replaced with underscores." - (should (string= (cj/music--safe-filename "my.playlist.name") - "my_playlist_name"))) - -(ert-deftest test-music-config--safe-filename-boundary-slashes-replaced () - "Validate slashes are replaced with underscores." - (should (string= (cj/music--safe-filename "folder/file") - "folder_file"))) - -(ert-deftest test-music-config--safe-filename-boundary-consecutive-invalid-chars () - "Validate consecutive invalid characters each become underscores." - (should (string= (cj/music--safe-filename "test!!!name") - "test___name"))) - -(ert-deftest test-music-config--safe-filename-boundary-empty-string-unchanged () - "Validate empty string remains unchanged." - (should (string= (cj/music--safe-filename "") - ""))) - -(ert-deftest test-music-config--safe-filename-boundary-only-invalid-chars () - "Validate string with only invalid characters becomes all underscores." - (should (string= (cj/music--safe-filename "!@#$%") - "_____"))) - -;;; Error Cases - -(ert-deftest test-music-config--safe-filename-error-nil-input-signals-error () - "Validate nil input signals error." - (should-error (cj/music--safe-filename nil) - :type 'wrong-type-argument)) - -(provide 'test-music-config--safe-filename) -;;; test-music-config--safe-filename.el ends here diff --git a/tests/test-music-config--save-helpers.el b/tests/test-music-config--save-helpers.el new file mode 100644 index 00000000..ffb0a477 --- /dev/null +++ b/tests/test-music-config--save-helpers.el @@ -0,0 +1,90 @@ +;;; test-music-config--save-helpers.el --- save default-name + directory tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The pure helpers behind the queue-first save flow: which name the save +;; prompt pre-fills (`cj/music--save-default-name') and which directory the +;; file lands in (`cj/music--save-directory'). An all-stream queue saves into +;; the radio playlist home (`cj/music-radio-save-dir'); anything else saves +;; into `cj/music-m3u-root'. + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for 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) + +(declare-function cj/music--save-default-name "music-config" (tracks file entries)) +(declare-function cj/music--save-directory "music-config" (tracks)) +(declare-function cj/music-radio--station-track "music-config" (st)) + +;;; --------------------------- save-default-name ------------------------------- + +(ert-deftest test-music-save-default-name-normal-associated-file-wins () + "Normal: an associated playlist file names the save, station or not." + (let ((tr (cj/music-radio--station-track '(:name "S" :url "https://s.example/x")))) + (should (equal (cj/music--save-default-name (list tr) "/pl/jazz.m3u" nil) + "jazz")))) + +(ert-deftest test-music-save-default-name-normal-station-title () + "Normal: with no file, the first url track's station name pre-fills." + (let ((tr (cj/music-radio--station-track + '(:name "Groove Salad" :url "https://gs.example/x")))) + (should (equal (cj/music--save-default-name (list tr) nil nil) + "Groove Salad")))) + +(ert-deftest test-music-save-default-name-normal-first-url-track-wins () + "Normal: a file track ahead of the station doesn't block the station name; +the first URL track with a name wins." + (let ((f (emms-track 'file "/music/a.flac")) + (tr (cj/music-radio--station-track + '(:name "Second Pick" :url "https://sp.example/x")))) + (should (equal (cj/music--save-default-name (list f tr) nil nil) + "Second Pick")))) + +(ert-deftest test-music-save-default-name-normal-entries-fallback () + "Normal: a propertyless url track resolves its name from ENTRIES." + (let* ((url "https://legacy.example/s") + (tr (emms-track 'url url)) + (entries (list (list url :name "Legacy FM" :uuid nil :favicon nil)))) + (should (equal (cj/music--save-default-name (list tr) nil entries) + "Legacy FM")))) + +(ert-deftest test-music-save-default-name-boundary-no-candidates-nil () + "Boundary: no file, no url tracks -> nil (caller falls back to a timestamp)." + (should-not (cj/music--save-default-name + (list (emms-track 'file "/music/a.flac")) nil nil)) + (should-not (cj/music--save-default-name nil nil nil))) + +;;; ---------------------------- save-directory --------------------------------- + +(ert-deftest test-music-save-directory-normal-all-streams-radio-dir () + "Normal: an all-stream queue saves into the radio playlist dir." + (let ((u1 (emms-track 'url "https://a.example/1")) + (u2 (emms-track 'url "https://b.example/2"))) + (should (equal (cj/music--save-directory (list u1 u2)) + cj/music-radio-save-dir)))) + +(ert-deftest test-music-save-directory-normal-mixed-goes-to-m3u-root () + "Normal: any non-stream track routes the save to the music playlist root." + (let ((u (emms-track 'url "https://a.example/1")) + (f (emms-track 'file "/music/a.flac"))) + (should (equal (cj/music--save-directory (list u f)) + cj/music-m3u-root)))) + +(ert-deftest test-music-save-directory-boundary-empty-goes-to-m3u-root () + "Boundary: an empty queue defaults to the music playlist root." + (should (equal (cj/music--save-directory nil) cj/music-m3u-root))) + +(provide 'test-music-config--save-helpers) +;;; test-music-config--save-helpers.el ends here diff --git a/tests/test-music-config--tidy-host.el b/tests/test-music-config--tidy-host.el new file mode 100644 index 00000000..92b104a6 --- /dev/null +++ b/tests/test-music-config--tidy-host.el @@ -0,0 +1,47 @@ +;;; test-music-config--tidy-host.el --- Tests for stream-URL host tidying -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--tidy-host': reduce a stream URL to a readable host +;; label (scheme dropped, a leading "www." removed), used as the last-resort +;; display name for a url track with no #EXTINF label. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for 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) + +(ert-deftest test-music-config--tidy-host-normal () + "Normal: scheme and path are dropped, host kept." + (should (string= (cj/music--tidy-host "https://ice6.somafm.com/groovesalad-256-mp3") + "somafm.com"))) + +(ert-deftest test-music-config--tidy-host-normal-http () + "Normal: plain http host with a port keeps the host, drops the port." + (should (string= (cj/music--tidy-host "http://stream.example.org:8000/live") + "example.org"))) + +(ert-deftest test-music-config--tidy-host-boundary-strip-www () + "Boundary: a leading www. is stripped." + (should (string= (cj/music--tidy-host "https://www.radioparadise.com/m3u/mp3-128.m3u") + "radioparadise.com"))) + +(ert-deftest test-music-config--tidy-host-boundary-bare-domain () + "Boundary: a two-label domain is returned unchanged." + (should (string= (cj/music--tidy-host "http://somafm.com/") "somafm.com"))) + +(ert-deftest test-music-config--tidy-host-error-not-a-url () + "Error: a non-URL string is returned as-is rather than erroring." + (should (string= (cj/music--tidy-host "not a url") "not a url"))) + +(provide 'test-music-config--tidy-host) +;;; test-music-config--tidy-host.el ends here diff --git a/tests/test-music-config--track-description.el b/tests/test-music-config--track-description.el deleted file mode 100644 index a1a1cc6d..00000000 --- a/tests/test-music-config--track-description.el +++ /dev/null @@ -1,181 +0,0 @@ -;;; test-music-config--track-description.el --- Tests for track description -*- coding: utf-8; lexical-binding: t; -*- -;; -;; Author: Craig Jennings <c@cjennings.net> -;; -;;; Commentary: -;; Unit tests for cj/music--track-description function. -;; Tests the custom track description that replaces EMMS's default file-path display -;; with human-readable formats based on track type and available metadata. -;; -;; Track construction: EMMS tracks are alists created with `emms-track' and -;; populated with `emms-track-set'. No playlist buffer or player state needed. -;; -;; Test organization: -;; - Normal Cases: Tagged tracks (artist+title+duration), partial metadata, file fallback, URL -;; - Boundary Cases: Empty strings, missing fields, special characters, long names -;; - Error Cases: Unknown track type fallback -;; -;;; Code: - -(require 'ert) - -;; 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-track-description--make-file-track (path &optional title artist duration) - "Create a file TRACK with PATH and optional metadata TITLE, ARTIST, DURATION." - (let ((track (emms-track 'file path))) - (when title (emms-track-set track 'info-title title)) - (when artist (emms-track-set track 'info-artist artist)) - (when duration (emms-track-set track 'info-playing-time duration)) - track)) - -(defun test-track-description--make-url-track (url &optional title artist duration) - "Create a URL TRACK with URL and optional metadata TITLE, ARTIST, DURATION." - (let ((track (emms-track 'url url))) - (when title (emms-track-set track 'info-title title)) - (when artist (emms-track-set track 'info-artist artist)) - (when duration (emms-track-set track 'info-playing-time duration)) - track)) - -;;; Normal Cases — Tagged tracks (artist + title + duration) - -(ert-deftest test-music-config--track-description-normal-full-metadata () - "Validate track with artist, title, and duration shows all three." - (let ((track (test-track-description--make-file-track - "/music/Kind of Blue/01 - So What.flac" - "So What" "Miles Davis" 562))) - (should (string= (cj/music--track-description track) - "Miles Davis - So What [9:22]")))) - -(ert-deftest test-music-config--track-description-normal-title-and-artist-no-duration () - "Validate track with artist and title but no duration omits bracket." - (let ((track (test-track-description--make-file-track - "/test/uncached-nodur.mp3" "Blue in Green" "Miles Davis"))) - (should (string= (cj/music--track-description track) - "Miles Davis - Blue in Green")))) - -(ert-deftest test-music-config--track-description-normal-title-only () - "Validate track with title but no artist shows title alone." - (let ((track (test-track-description--make-file-track - "/test/uncached-noartist.mp3" "Flamenco Sketches" nil 566))) - (should (string= (cj/music--track-description track) - "Flamenco Sketches [9:26]")))) - -(ert-deftest test-music-config--track-description-normal-title-only-no-duration () - "Validate track with only title shows just the title." - (let ((track (test-track-description--make-file-track - "/test/uncached-titleonly.mp3" "All Blues"))) - (should (string= (cj/music--track-description track) - "All Blues")))) - -;;; Normal Cases — File tracks without tags - -(ert-deftest test-music-config--track-description-normal-file-no-tags () - "Validate untagged file shows filename without path or extension." - (let ((track (test-track-description--make-file-track - "/music/Kind of Blue/02 - Freddie Freeloader.flac"))) - (should (string= (cj/music--track-description track) - "02 - Freddie Freeloader")))) - -(ert-deftest test-music-config--track-description-normal-file-nested-path () - "Validate deeply nested path still shows only the filename." - (let ((track (test-track-description--make-file-track - "/music/Jazz/Miles Davis/Kind of Blue/01 - So What.mp3"))) - (should (string= (cj/music--track-description track) - "01 - So What")))) - -;;; Normal Cases — URL tracks - -(ert-deftest test-music-config--track-description-normal-url-plain () - "Validate plain URL is shown as-is." - (let ((track (test-track-description--make-url-track - "https://radio.example.com/stream"))) - (should (string= (cj/music--track-description track) - "https://radio.example.com/stream")))) - -(ert-deftest test-music-config--track-description-normal-url-percent-encoded () - "Validate percent-encoded URL characters are decoded." - (let ((track (test-track-description--make-url-track - "https://radio.example.com/my%20station%21"))) - (should (string= (cj/music--track-description track) - "https://radio.example.com/my station!")))) - -(ert-deftest test-music-config--track-description-normal-url-with-tags () - "Validate URL track with tags uses tag display, not URL." - (let ((track (test-track-description--make-url-track - "https://radio.example.com/stream" - "Jazz FM" "Radio Station" 0))) - ;; Duration 0 → nil from format-duration, so no bracket - (should (string= (cj/music--track-description track) - "Radio Station - Jazz FM")))) - -;;; Boundary Cases - -(ert-deftest test-music-config--track-description-boundary-empty-title-string () - "Validate empty title string is still truthy, shows empty result." - (let ((track (test-track-description--make-file-track - "/music/track.mp3" "" "Artist"))) - ;; Empty string is non-nil, so title branch is taken - (should (string= (cj/music--track-description track) - "Artist - ")))) - -(ert-deftest test-music-config--track-description-boundary-file-no-extension () - "Validate file without extension shows full filename." - (let ((track (test-track-description--make-file-track "/music/README"))) - (should (string= (cj/music--track-description track) - "README")))) - -(ert-deftest test-music-config--track-description-boundary-file-multiple-dots () - "Validate file with multiple dots strips only the final extension." - (let ((track (test-track-description--make-file-track - "/music/disc.1.track.03.flac"))) - (should (string= (cj/music--track-description track) - "disc.1.track.03")))) - -(ert-deftest test-music-config--track-description-boundary-unicode-title () - "Validate unicode characters in metadata are preserved." - (let ((track (test-track-description--make-file-track - "/music/track.mp3" "夜に駆ける" "YOASOBI" 258))) - (should (string= (cj/music--track-description track) - "YOASOBI - 夜に駆ける [4:18]")))) - -(ert-deftest test-music-config--track-description-boundary-url-utf8-percent-encoded () - "Validate percent-encoded UTF-8 in URL is decoded correctly." - (let ((track (test-track-description--make-url-track - "https://example.com/caf%C3%A9"))) - (should (string= (cj/music--track-description track) - "https://example.com/café")))) - -(ert-deftest test-music-config--track-description-boundary-short-duration () - "Validate 1-second track formats correctly in bracket." - (let ((track (test-track-description--make-file-track - "/music/t.mp3" "Beep" nil 1))) - (should (string= (cj/music--track-description track) - "Beep [0:01]")))) - -;;; Error Cases - -(ert-deftest test-music-config--track-description-error-unknown-type-fallback () - "Validate unknown track type uses emms-track-simple-description fallback." - (let ((track (emms-track 'streamlist "https://example.com/playlist.m3u"))) - ;; Should not error; falls through to simple-description - (let ((result (cj/music--track-description track))) - (should (stringp result)) - (should (string-match-p "example\\.com" result))))) - -(provide 'test-music-config--track-description) -;;; test-music-config--track-description.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 1f4365a4..7d9adbed 100644 --- a/tests/test-music-config-create-radio-station.el +++ b/tests/test-music-config-create-radio-station.el @@ -1,153 +1,130 @@ -;;; test-music-config-create-radio-station.el --- Tests for radio station creation -*- coding: utf-8; lexical-binding: t; -*- +;;; test-music-config-create-radio-station.el --- Tests for manual radio-station entry -*- coding: utf-8; lexical-binding: t; -*- ;; ;; Author: Craig Jennings <c@cjennings.net> ;; ;;; Commentary: -;; Unit tests for cj/music-create-radio-station function. -;; Tests M3U file creation for radio stations with stream URLs. +;; Unit tests for cj/music-create-radio-station under the queue-first model: +;; a hand-entered name + URL becomes a url track in the playlist queue (with +;; the name as its title property) and playback starts. Nothing is written +;; to disk — saving is the normal playlist-save flow. ;; ;; Test organization: -;; - Normal Cases: Standard creation, EXTM3U format, safe filename -;; - Boundary Cases: Unicode name, complex URL, overwrite confirmed -;; - Error Cases: Empty name, empty URL, overwrite declined -;; +;; - Normal Cases: track queued with title, playback started, no file written +;; - Boundary Cases: unicode name preserved verbatim +;; - Error Cases: empty name, empty URL + ;;; Code: (require 'ert) -(require 'testutil-general) +(require 'cl-lib) ;; Stub missing dependencies before loading music-config (defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") -;; Load production code -(require 'music-config) - -;;; Setup & Teardown +(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))) -(defun test-music-config-create-radio-station-setup () - "Setup test environment with temp directory for M3U output." - (cj/create-test-base-dir) - (cj/create-test-subdirectory "radio-playlists")) +(require 'emms) +(require 'music-config) -(defun test-music-config-create-radio-station-teardown () - "Clean up test environment." - (cj/delete-test-base-dir)) +(defmacro test-music-create-radio--with-env (&rest body) + "Run BODY with a fresh playlist buffer, playback mocked, messages captured." + `(let* ((cj/music-playlist-buffer-name + (generate-new-buffer-name "*test-create-radio*")) + (emms-player-playing-p nil) + (started 0) (msg nil)) + (ignore started msg) + (unwind-protect + (cl-letf (((symbol-function 'emms-start) + (lambda () (setq started (1+ started)))) + ((symbol-function 'emms-stop) #'ignore) + ((symbol-function 'message) + (lambda (fmt &rest args) + (when fmt (setq msg (apply #'format fmt args)))))) + ,@body) + (when (get-buffer cj/music-playlist-buffer-name) + (kill-buffer cj/music-playlist-buffer-name))))) + +(defun test-music-create-radio--queued-tracks () + "Track objects currently in the test playlist buffer." + (let ((tracks '())) + (with-current-buffer cj/music-playlist-buffer-name + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when-let ((tr (emms-playlist-track-at (point)))) + (push tr tracks)) + (forward-line 1)))) + (nreverse tracks))) ;;; Normal Cases -(ert-deftest test-music-config-create-radio-station-normal-creates-m3u-file () - "Creating a radio station produces an M3U file in the music root." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Jazz FM" "http://stream.jazzfm.com/radio") - (let ((expected-file (expand-file-name "Jazz_FM_Radio.m3u" test-dir))) - (should (file-exists-p expected-file)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-normal-extm3u-format () - "Created file contains EXTM3U header, EXTINF with station name, and URL." - (let ((test-dir (test-music-config-create-radio-station-setup))) +(ert-deftest test-music-config-create-radio-station-normal-queues-track () + "Normal: name+url queues a url track carrying the name, and playback starts." + (test-music-create-radio--with-env + (cj/music-create-radio-station "Jazz FM" "http://stream.jazzfm.com/radio") + (let ((tracks (test-music-create-radio--queued-tracks))) + (should (= (length tracks) 1)) + (should (eq (emms-track-type (car tracks)) 'url)) + (should (equal (emms-track-name (car tracks)) "http://stream.jazzfm.com/radio")) + (should (equal (emms-track-get (car tracks) 'info-title) "Jazz FM"))) + (should (= started 1)) + (should (string-match-p "Jazz FM" msg)))) + +(ert-deftest test-music-config-create-radio-station-normal-writes-no-file () + "Normal: nothing lands on disk — saving is the playlist-save flow's job." + (let ((tmp (file-name-as-directory (make-temp-file "cj-radio-nofile-" t)))) (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Jazz FM" "http://stream.jazzfm.com/radio") - (let ((content (with-temp-buffer - (insert-file-contents - (expand-file-name "Jazz_FM_Radio.m3u" test-dir)) - (buffer-string)))) - (should (string-match-p "^#EXTM3U" content)) - (should (string-match-p "#EXTINF:-1,Jazz FM" content)) - (should (string-match-p "http://stream.jazzfm.com/radio" content)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-normal-safe-filename () - "Station name with special characters produces filesystem-safe filename." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Rock & Roll 101.5" "http://example.com/stream") - ;; Spaces and special chars replaced with underscores - (let ((expected-file (expand-file-name "Rock___Roll_101_5_Radio.m3u" test-dir))) - (should (file-exists-p expected-file)))) - (test-music-config-create-radio-station-teardown)))) + (test-music-create-radio--with-env + (let ((cj/music-m3u-root tmp) + (cj/music-radio-save-dir tmp)) + (cj/music-create-radio-station "NPR" "https://example.test/stream") + (should-not (directory-files tmp nil "\\.m3u\\'")))) + (delete-directory tmp t)))) ;;; Boundary Cases -(ert-deftest test-music-config-create-radio-station-boundary-unicode-name-safe-filename () - "Unicode station name produces safe filename while preserving name in EXTINF." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Klassik Radio" "http://example.com/stream") - ;; Name is all ASCII-safe, so filename uses it directly - (should (file-exists-p (expand-file-name "Klassik_Radio_Radio.m3u" test-dir))) - ;; Original name preserved in EXTINF inside the file - (let ((content (with-temp-buffer - (insert-file-contents - (expand-file-name "Klassik_Radio_Radio.m3u" test-dir)) - (buffer-string)))) - (should (string-match-p "Klassik Radio" content)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-boundary-url-with-query-params () - "Complex URL with query parameters preserved in file content." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir) - (url "https://stream.example.com/radio?format=mp3&quality=320&token=abc123")) - (cj/music-create-radio-station "Test Radio" url) - (let ((content (with-temp-buffer - (insert-file-contents - (expand-file-name "Test_Radio_Radio.m3u" test-dir)) - (buffer-string)))) - (should (string-match-p (regexp-quote url) content)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-boundary-overwrite-confirmed () - "Overwriting existing file when user confirms succeeds." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - ;; Create initial file - (cj/music-create-radio-station "MyRadio" "http://old.url/stream") - (let ((file (expand-file-name "MyRadio_Radio.m3u" test-dir))) - (should (file-exists-p file)) - ;; Overwrite with user confirming - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) - (cj/music-create-radio-station "MyRadio" "http://new.url/stream")) - ;; File should now contain new URL - (let ((content (with-temp-buffer - (insert-file-contents file) - (buffer-string)))) - (should (string-match-p "http://new.url/stream" content)) - (should-not (string-match-p "http://old.url/stream" content))))) - (test-music-config-create-radio-station-teardown)))) +(ert-deftest test-music-config-create-radio-station-boundary-unicode-name () + "Boundary: a unicode name is kept verbatim on the track (no filename munging)." + (test-music-create-radio--with-env + (cj/music-create-radio-station "Café Del Mar ☕" "https://cafe.example/stream") + (should (equal (emms-track-get (car (test-music-create-radio--queued-tracks)) + 'info-title) + "Café Del Mar ☕")))) + +;;; Keymap + +(ert-deftest test-music-config-radio-map-prefix-mirrors-playlist-keys () + "Normal: C-; m r is a radio prefix whose n/t/m mirror the playlist buffer." + (let ((map (lookup-key cj/music-map "r"))) + (should (keymapp map)) + (should (eq (lookup-key map "n") 'cj/music-radio-search-by-name)) + (should (eq (lookup-key map "t") 'cj/music-radio-search-by-tag)) + (should (eq (lookup-key map "m") 'cj/music-create-radio-station)))) + +(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." + (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))) ;;; Error Cases (ert-deftest test-music-config-create-radio-station-error-empty-name-signals-user-error () - "Empty station name signals user-error." - (should-error (cj/music-create-radio-station "" "http://example.com/stream") - :type 'user-error)) + "Error: empty name signals user-error." + (should-error (cj/music-create-radio-station "" "https://x") :type 'user-error)) (ert-deftest test-music-config-create-radio-station-error-empty-url-signals-user-error () - "Empty URL signals user-error." - (should-error (cj/music-create-radio-station "Test Radio" "") - :type 'user-error)) - -(ert-deftest test-music-config-create-radio-station-error-overwrite-declined-signals-user-error () - "Declining overwrite signals user-error." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - ;; Create initial file - (cj/music-create-radio-station "MyRadio" "http://old.url/stream") - ;; Decline overwrite - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) nil))) - (should-error (cj/music-create-radio-station "MyRadio" "http://new.url/stream") - :type 'user-error))) - (test-music-config-create-radio-station-teardown)))) + "Error: empty URL signals user-error." + (should-error (cj/music-create-radio-station "NPR" "") :type 'user-error)) (provide 'test-music-config-create-radio-station) ;;; test-music-config-create-radio-station.el ends here 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-music-config-more-commands.el b/tests/test-music-config-more-commands.el index c351c1f1..530aa379 100644 --- a/tests/test-music-config-more-commands.el +++ b/tests/test-music-config-more-commands.el @@ -9,7 +9,9 @@ ;; cj/music-playlist-edit ;; cj/music-playlist-toggle ;; cj/music-playlist-show -;; cj/music-create-radio-station +;; +;; cj/music-create-radio-station lives in +;; test-music-config-create-radio-station.el. ;;; Code: @@ -17,12 +19,21 @@ (require 'cl-lib) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for 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) ;; Top-level defvars so let-binds reach the dynamic var under lexical ;; scope. (defvar cj/music-playlist-file nil) -(defvar emms-source-playlist-ask-before-overwrite t) ;;; cj/music-playlist-load @@ -56,28 +67,87 @@ ;;; cj/music-playlist-save -(ert-deftest test-music-playlist-save-writes-fresh-name () - "Normal: save with a fresh name writes via emms-playlist-save." - (let* ((tmp (file-name-as-directory (make-temp-file "cj-music-save-" t))) - (cj/music-m3u-root tmp) - saved-args msg) - (unwind-protect - (cl-letf (((symbol-function 'cj/music--get-m3u-basenames) - (lambda () nil)) - ((symbol-function 'completing-read) - (lambda (&rest _) "fresh")) - ((symbol-function 'cj/music--ensure-playlist-buffer) - (lambda () (current-buffer))) - ((symbol-function 'emms-playlist-save) - (lambda (fmt path) (setq saved-args (list fmt path)))) - ((symbol-function 'cj/music--sync-playlist-file) #'ignore) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/music-playlist-save)) - (delete-directory tmp t)) - (should (equal (car saved-args) 'm3u)) - (should (string-match-p "fresh\\.m3u\\'" (cadr saved-args))) - (should (string-match-p "Saved playlist" msg)))) +(defmacro test-music-save--with-env (&rest body) + "Run BODY with a fresh playlist buffer and temp save directories. +Binds TMP-M3U and TMP-RADIO (both cleaned up) and captures completing-read's +INITIAL argument in CR-INITIAL." + `(let* ((cj/music-playlist-buffer-name + (generate-new-buffer-name "*test-save*")) + (tmp-m3u (file-name-as-directory (make-temp-file "cj-save-m3u-" t))) + (tmp-radio (file-name-as-directory (make-temp-file "cj-save-radio-" t))) + (cj/music-m3u-root tmp-m3u) + (cj/music-radio-save-dir tmp-radio) + (cr-initial 'unset)) + (ignore cr-initial) + (unwind-protect + (cl-letf (((symbol-function 'message) #'ignore) + ((symbol-function 'completing-read) + (lambda (_prompt _coll &optional _pred _req initial _hist def &rest _) + (setq cr-initial initial) + (or initial def "fallback")))) + ,@body) + (when (get-buffer cj/music-playlist-buffer-name) + (kill-buffer cj/music-playlist-buffer-name)) + (delete-directory tmp-m3u t) + (delete-directory tmp-radio t)))) + +(defun test-music-save--queue (tracks) + "Put TRACKS into the (fresh) test playlist buffer." + (with-current-buffer (cj/music--ensure-playlist-buffer) + (save-excursion + (goto-char (point-max)) + (dolist (tr tracks) + (emms-playlist-insert-track tr))))) + +(ert-deftest test-music-playlist-save-station-queue-prefills-and-targets-radio-dir () + "Normal: an all-stream queue pre-fills the station name and saves into the +radio dir with the station metadata written." + (test-music-save--with-env + (let ((tr (emms-track 'url "https://gs.example/stream"))) + (emms-track-set tr 'info-title "Groove Salad") + (emms-track-set tr 'radio-uuid "uuid-gs") + (test-music-save--queue (list tr))) + (cj/music-playlist-save) + (should (equal cr-initial "Groove Salad")) + (let ((file (expand-file-name "Groove Salad.m3u" tmp-radio))) + (should (file-exists-p file)) + (with-temp-buffer + (insert-file-contents file) + (let ((text (buffer-string))) + (should (string-match-p "^#EXTINF:-1,Groove Salad$" text)) + (should (string-match-p "^#RADIOBROWSERUUID:uuid-gs$" text)) + (should (string-match-p "^https://gs\\.example/stream$" text))))) + (should-not (directory-files tmp-m3u nil "\\.m3u\\'")))) + +(ert-deftest test-music-playlist-save-file-queue-targets-m3u-root-no-prefill () + "Normal: a file queue saves into the music root with no station pre-fill." + (test-music-save--with-env + (test-music-save--queue (list (emms-track 'file "/music/a.flac"))) + (cj/music-playlist-save) + (should-not cr-initial) + (should (= (length (directory-files tmp-m3u nil "\\.m3u\\'")) 1)) + (should-not (directory-files tmp-radio nil "\\.m3u\\'")))) + +(ert-deftest test-music-playlist-save-associated-file-name-wins-over-station () + "Normal: a queue with an associated playlist file defaults to that name, +even when it contains stations." + (test-music-save--with-env + (let ((tr (emms-track 'url "https://gs.example/stream"))) + (emms-track-set tr 'info-title "Groove Salad") + (test-music-save--queue (list tr))) + (with-current-buffer (cj/music--ensure-playlist-buffer) + (setq cj/music-playlist-file (expand-file-name "morning.m3u" tmp-radio))) + (cj/music-playlist-save) + (should-not cr-initial) + (should (file-exists-p (expand-file-name "morning.m3u" tmp-radio))))) + +(ert-deftest test-music-playlist-save-error-empty-name () + "Error: an empty name at the prompt signals user-error, not a hidden .m3u." + (test-music-save--with-env + (test-music-save--queue (list (emms-track 'url "https://x.example/s"))) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) ""))) + (should-error (cj/music-playlist-save) :type 'user-error)) + (should-not (directory-files tmp-radio nil "m3u")))) ;;; cj/music-playlist-edit @@ -138,36 +208,5 @@ (should (eq switched buf)) (should msg))) -;;; cj/music-create-radio-station - -(ert-deftest test-music-create-radio-station-writes-m3u () - "Normal: with name+url, an EXTM3U-style file is written into music-m3u-root." - (let* ((tmp (file-name-as-directory (make-temp-file "cj-music-radio-" t))) - (cj/music-m3u-root tmp) - msg) - (unwind-protect - (progn - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/music-create-radio-station "NPR" "https://example.test/stream")) - (let ((file (expand-file-name "NPR_Radio.m3u" tmp))) - (should (file-exists-p file)) - (with-temp-buffer - (insert-file-contents file) - (let ((text (buffer-string))) - (should (string-match-p "#EXTM3U" text)) - (should (string-match-p "NPR" text)) - (should (string-match-p "https://example.test/stream" text)))))) - (delete-directory tmp t)) - (should (string-match-p "Created radio station" msg)))) - -(ert-deftest test-music-create-radio-station-rejects-empty-name () - "Error: an empty name is rejected with user-error." - (should-error (cj/music-create-radio-station "" "https://x") :type 'user-error)) - -(ert-deftest test-music-create-radio-station-rejects-empty-url () - "Error: an empty URL is rejected with user-error." - (should-error (cj/music-create-radio-station "NPR" "") :type 'user-error)) - (provide 'test-music-config-more-commands) ;;; test-music-config-more-commands.el ends here diff --git a/tests/test-nov-reading--config-defaults.el b/tests/test-nov-reading--config-defaults.el new file mode 100644 index 00000000..ff52d8f5 --- /dev/null +++ b/tests/test-nov-reading--config-defaults.el @@ -0,0 +1,67 @@ +;;; test-nov-reading--config-defaults.el --- nov reading default/order tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Asserts the shipped reading-view defaults: a fresh EPUB opens dark, and the +;; `c' cycle runs dark -> sepia -> light -> none -> back. The pure-logic file +;; test-nov-reading--palette.el covers the cycle mechanics on fixtures; this file +;; pins the real `cj/nov-reading-palettes' / `cj/nov-reading-default-palette' +;; values so a reorder can't silently drift the default or the cycle order. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'nov-reading) + +(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." + (should (equal cj/nov-reading-default-palette "dark"))) + +(ert-deftest test-nov-reading-config-order-is-dark-sepia-light () + "Normal: the shipped palette order is dark, then sepia, then light." + (should (equal (mapcar #'car cj/nov-reading-palettes) + '("dark" "sepia" "light")))) + +(ert-deftest test-nov-reading-config-cycle-from-default () + "Normal: cycling from the default advances dark -> sepia -> light -> none -> dark." + (let ((names (mapcar #'car cj/nov-reading-palettes))) + (should (equal (cj/nov--next-reading-palette "dark" names) "sepia")) + (should (equal (cj/nov--next-reading-palette "sepia" names) "light")) + (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..21842600 --- /dev/null +++ b/tests/test-org-agenda-frame.el @@ -0,0 +1,999 @@ +;;; 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 span is seven days anchored to today, not Monday." + (let ((s (test-org-agenda-frame--block-settings))) + (should (equal (cadr (assq 'org-agenda-span s)) 7)) + (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-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-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 "7-day view" 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 takes the safe-redo path." + (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))) + +(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 '("w" "d" "y" "f" "b" "j" "g")) + (should (eq (lookup-key cj/agenda-frame-mode-map (kbd key)) + 'cj/--agenda-frame-denied-fixed-view)))) + +(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-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-not-explicitly-bound () + "Boundary: a mutation key (t = org-agenda-todo) is not explicitly bound, so the +[t] catch-all denies it as read-only." + (should (null (lookup-key cj/agenda-frame-mode-map (kbd "t"))))) + +;;; 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-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-capture-config--neutralize.el b/tests/test-org-capture-config--neutralize.el new file mode 100644 index 00000000..4a03830a --- /dev/null +++ b/tests/test-org-capture-config--neutralize.el @@ -0,0 +1,136 @@ +;;; test-org-capture-config--neutralize.el --- Popup neutralize-guard tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the "org-capture" popup neutralize guards. The popup frame opens +;; showing the daemon's last buffer; if a capture aborts before its UI paints, +;; the popup lingers on that buffer, and a live eat/vterm terminal shown there +;; clamps the real frame to the popup's rows. The guards repoint every +;; non-capture-UI window of the popup at *scratch*: one fires on frame creation +;; (after-make-frame-functions), one on any buffer change +;; (window-buffer-change-functions). +;; +;; The tests drive the real batch frame (renamed to "org-capture" and restored +;; in cleanup, the same idiom as the popup-window integration test) rather than +;; mocking frame primitives. `window-buffer-change-functions' only runs during +;; redisplay, so the module's own hook cannot fire mid-test in batch. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'org) +(require 'org-capture) +(require 'user-constants) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-capture-config) + +(defmacro test-neutralize--with-popup-frame (buffer-name &rest body) + "Run BODY with the batch frame named \"org-capture\" showing BUFFER-NAME. +The frame name reverts to auto-naming and the test buffer is killed +afterward. BODY sees the buffer bound to `buf'." + (declare (indent 1)) + `(let ((buf (get-buffer-create ,buffer-name))) + (unwind-protect + (progn + (set-frame-parameter nil 'name "org-capture") + (delete-other-windows) + (set-window-buffer (selected-window) buf) + ,@body) + ;; Restore to nil, not the saved name: the batch frame's auto name is + ;; "F1", and Emacs refuses to set F<num>-shaped names explicitly. + ;; nil reverts to auto-naming (same idiom as the popup-window test). + (set-frame-parameter nil 'name nil) + (when (buffer-live-p buf) (kill-buffer buf))))) + +;;; cj/org-capture--neutralize-frame + +(ert-deftest test-org-capture-config-neutralize-frame-evicts-plain-buffer () + "Normal: a non-capture-UI buffer in the popup frame is repointed to *scratch*." + (test-neutralize--with-popup-frame "neutralize-plain.org" + (cj/org-capture--neutralize-frame (selected-frame)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +(ert-deftest test-org-capture-config-neutralize-frame-spares-capture-buffer () + "Normal: a CAPTURE-* buffer is capture UI and stays put." + (test-neutralize--with-popup-frame "CAPTURE-neutralize.org" + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) buf)))) + +(ert-deftest test-org-capture-config-neutralize-frame-spares-select-menu () + "Normal: the *Org Select* template menu is capture UI and stays put." + (test-neutralize--with-popup-frame "*Org Select*" + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) buf)))) + +(ert-deftest test-org-capture-config-neutralize-frame-scratch-untouched () + "Boundary: a window already on *scratch* is left alone (idempotent)." + (let ((scratch (get-buffer-create "*scratch*"))) + (unwind-protect + (progn + (set-frame-parameter nil 'name "org-capture") + (delete-other-windows) + (set-window-buffer (selected-window) scratch) + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) scratch)) + ;; Second pass is also a no-op. + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) scratch))) + (set-frame-parameter nil 'name nil)))) + +(ert-deftest test-org-capture-config-neutralize-frame-other-frame-untouched () + "Boundary: a frame not named \"org-capture\" is never neutralized." + (let ((buf (get-buffer-create "neutralize-other-frame.org"))) + (unwind-protect + (progn + (set-frame-parameter nil 'name "some-other-frame") + (delete-other-windows) + (set-window-buffer (selected-window) buf) + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) buf))) + (set-frame-parameter nil 'name nil) + (when (buffer-live-p buf) (kill-buffer buf))))) + +(ert-deftest test-org-capture-config-neutralize-frame-dead-input-no-error () + "Error: nil and non-frame inputs are ignored without raising." + (should-not (cj/org-capture--neutralize-frame nil)) + (should-not (cj/org-capture--neutralize-frame 'not-a-frame))) + +;;; cj/org-capture--neutralize-new-frame (Guard 1 wrapper) + +(ert-deftest test-org-capture-config-neutralize-new-frame-delegates () + "Normal: the frame-creation wrapper neutralizes the popup frame." + (test-neutralize--with-popup-frame "neutralize-new-frame.org" + (cj/org-capture--neutralize-new-frame (selected-frame)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +;;; cj/org-capture--neutralize-on-buffer-change (Guard 2 wrapper) + +(ert-deftest test-org-capture-config-neutralize-on-buffer-change-window-arg () + "Normal: a window argument resolves to its frame and neutralizes it. +`window-buffer-change-functions' passes a window when buffer-local." + (test-neutralize--with-popup-frame "neutralize-window-arg.org" + (cj/org-capture--neutralize-on-buffer-change (selected-window)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +(ert-deftest test-org-capture-config-neutralize-on-buffer-change-frame-arg () + "Normal: a frame argument passes straight through. +`window-buffer-change-functions' passes a frame when global." + (test-neutralize--with-popup-frame "neutralize-frame-arg.org" + (cj/org-capture--neutralize-on-buffer-change (selected-frame)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +;;; Hook wiring + +(ert-deftest test-org-capture-config-neutralize-hooks-registered () + "Normal: both guards are installed on their hooks at module load." + (should (memq #'cj/org-capture--neutralize-new-frame + after-make-frame-functions)) + (should (memq #'cj/org-capture--neutralize-on-buffer-change + window-buffer-change-functions))) + +(provide 'test-org-capture-config--neutralize) +;;; test-org-capture-config--neutralize.el ends here diff --git a/tests/test-org-config-noop-state-log.el b/tests/test-org-config-noop-state-log.el new file mode 100644 index 00000000..125eb300 --- /dev/null +++ b/tests/test-org-config-noop-state-log.el @@ -0,0 +1,59 @@ +;;; test-org-config-noop-state-log.el --- Suppress no-op state-change logs -*- lexical-binding: t; -*- + +;;; Commentary: +;; org's state-change logging writes "- State X from X" lines for no-op +;; transitions (identical from/to state), which carry no information. With +;; `org-log-into-drawer' nil those lines also land inline, where they wedge +;; between a heading and its planning line and break org's parser. Two fixes +;; in `cj/org-todo-settings': log state changes into :LOGBOOK: drawers +;; (`org-log-into-drawer' t), and suppress no-op state logs at the +;; `org-add-log-setup' choke point via `cj/org--suppress-noop-state-log'. + +;;; Code: + +(require 'ert) +(require 'org) ;; declares the org-log-* vars special +(require 'org-config) + +(ert-deftest test-org-config-log-into-drawer-enabled () + "Normal: cj/org-todo-settings enables org-log-into-drawer (LOGBOOK)." + (let ((org-log-into-drawer nil)) + (cj/org-todo-settings) + (should (eq org-log-into-drawer t)))) + +(ert-deftest test-org-config-noop-state-log-p-identical-is-noop () + "Normal: identical from/to state on a 'state purpose is a no-op." + (should (cj/org--noop-state-log-p 'state "TODO" "TODO"))) + +(ert-deftest test-org-config-noop-state-log-p-real-change-not-noop () + "Normal: a genuine state change is not a no-op." + (should-not (cj/org--noop-state-log-p 'state "DONE" "TODO"))) + +(ert-deftest test-org-config-noop-state-log-p-nil-prev-not-noop () + "Boundary: a nil previous state (initial log) is not a no-op." + (should-not (cj/org--noop-state-log-p 'state "TODO" nil))) + +(ert-deftest test-org-config-noop-state-log-p-non-state-purpose-not-noop () + "Boundary: identical strings under a non-state purpose are not suppressed." + (should-not (cj/org--noop-state-log-p 'note "x" "x"))) + +(ert-deftest test-org-config-noop-state-log-p-nil-both-not-noop () + "Error: a nil/nil state pair is not a suppressible no-op." + (should-not (cj/org--noop-state-log-p 'state nil nil))) + +(ert-deftest test-org-config-suppress-advice-skips-noop () + "Normal: the advice does NOT call through for a no-op state transition." + (let ((called nil)) + (cj/org--suppress-noop-state-log + (lambda (&rest _) (setq called t)) 'state "TODO" "TODO") + (should-not called))) + +(ert-deftest test-org-config-suppress-advice-passes-real-change () + "Normal: the advice calls through for a genuine state change." + (let ((called nil)) + (cj/org--suppress-noop-state-log + (lambda (&rest _) (setq called t)) 'state "DONE" "TODO") + (should called))) + +(provide 'test-org-config-noop-state-log) +;;; test-org-config-noop-state-log.el ends here diff --git a/tests/test-org-contacts-config-find.el b/tests/test-org-contacts-config-find.el new file mode 100644 index 00000000..60a5e713 --- /dev/null +++ b/tests/test-org-contacts-config-find.el @@ -0,0 +1,72 @@ +;;; test-org-contacts-config-find.el --- Tests for cj/org-contacts-find -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/org-contacts-find collects contact headings (name, position, and the +;; EMAIL/PHONE annotation) before prompting, then jumps to the selected +;; heading's stored position. These tests pin the collector helper and a +;; command-level smoke test: the jump must land on the heading, never on a +;; body line that merely mentions the name. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'org) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-contacts-config) + +;;; cj/--org-contacts-collect + +(ert-deftest test-org-contacts-collect-returns-name-position-info () + "Normal: collector returns heading name, heading position, and EMAIL/PHONE." + (with-temp-buffer + (org-mode) + (insert "* Alice\n:PROPERTIES:\n:EMAIL: alice@example.com\n:END:\n" + "some body text mentioning Bob\n" + "* Bob\n:PROPERTIES:\n:PHONE: 555-1234\n:END:\n") + (let* ((alist (cj/--org-contacts-collect (current-buffer))) + (alice (assoc "Alice" alist)) + (bob (assoc "Bob" alist))) + (should (equal (length alist) 2)) + (should (equal (nth 2 alice) "alice@example.com")) + (should (equal (nth 2 bob) "555-1234")) + ;; positions land on the headings, not the body line that mentions Bob + (should (save-excursion (goto-char (nth 1 alice)) (looking-at "\\* Alice"))) + (should (save-excursion (goto-char (nth 1 bob)) (looking-at "\\* Bob")))))) + +(ert-deftest test-org-contacts-collect-empty-buffer-returns-nil () + "Boundary: a buffer with no headings yields an empty alist." + (with-temp-buffer + (org-mode) + (should (null (cj/--org-contacts-collect (current-buffer)))))) + +(ert-deftest test-org-contacts-collect-heading-without-props-has-nil-info () + "Error: a heading with no EMAIL or PHONE yields nil info." + (with-temp-buffer + (org-mode) + (insert "* Carol\n") + (let ((alist (cj/--org-contacts-collect (current-buffer)))) + (should (equal (nth 2 (assoc "Carol" alist)) nil))))) + +;;; cj/org-contacts-find + +(ert-deftest test-org-contacts-find-jumps-to-heading-not-body () + "Normal: selecting a contact jumps to its heading, not a body mention." + (let ((contacts-file (make-temp-file "org-contacts-test-" nil ".org"))) + (unwind-protect + (progn + (with-temp-file contacts-file + (insert "* Alice\n:PROPERTIES:\n:EMAIL: alice@example.com\n:END:\n" + "note: call Bob about Alice\n" + "* Bob\n:PROPERTIES:\n:PHONE: 555-1234\n:END:\n")) + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest _) "Bob")) + ((symbol-function 'org-fold-show-entry) #'ignore) + ((symbol-function 'org-reveal) #'ignore)) + (cj/org-contacts-find) + (should (looking-at "\\* Bob")))) + (delete-file contacts-file)))) + +(provide 'test-org-contacts-config-find) +;;; test-org-contacts-config-find.el ends here diff --git a/tests/test-org-drill-config-source.el b/tests/test-org-drill-config-source.el new file mode 100644 index 00000000..ccda99ef --- /dev/null +++ b/tests/test-org-drill-config-source.el @@ -0,0 +1,31 @@ +;;; test-org-drill-config-source.el --- Tests for org-drill source selection -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--org-drill-source-keywords decides how use-package obtains org-drill: +;; a local dev checkout via :load-path when it exists, otherwise the upstream +;; repo via :vc. Without this, a machine lacking the checkout hits :demand t +;; against a nonexistent :load-path and drill fails to load entirely. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-drill-config) + +(ert-deftest test-org-drill-source-keywords-uses-load-path-when-checkout-exists () + "Normal: an existing checkout directory selects :load-path." + (let ((dir (make-temp-file "org-drill-checkout-" t))) + (unwind-protect + (should (equal (cj/--org-drill-source-keywords dir) + (list :load-path dir))) + (delete-directory dir t)))) + +(ert-deftest test-org-drill-source-keywords-falls-back-to-vc-when-absent () + "Error: a missing checkout falls back to a :vc install spec." + (let ((kws (cj/--org-drill-source-keywords "/nonexistent/org-drill-xyz"))) + (should (eq (car kws) :vc)) + (should (plist-get (nth 1 kws) :url)))) + +(provide 'test-org-drill-config-source) +;;; test-org-drill-config-source.el ends here diff --git a/tests/test-org-reveal-config-keymap.el b/tests/test-org-reveal-config-keymap.el new file mode 100644 index 00000000..17a21b19 --- /dev/null +++ b/tests/test-org-reveal-config-keymap.el @@ -0,0 +1,38 @@ +;;; test-org-reveal-config-keymap.el --- Tests for org-reveal-config prefix keymap -*- lexical-binding: t; -*- + +;;; Commentary: +;; The presentation commands are reached through `cj/reveal-map', a prefix +;; keymap registered under "C-; p" via `cj/register-prefix-map'. These +;; tests pin that structure so the module can't silently regress to raw +;; `global-set-key' calls (which carry a hidden load-order dependency on +;; keybindings.el establishing "C-;" as a prefix first). + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'keybindings) +(require 'org-reveal-config) + +(ert-deftest test-org-reveal-config-reveal-map-is-a-keymap () + "Normal: `cj/reveal-map' is a keymap." + (should (keymapp cj/reveal-map))) + +(ert-deftest test-org-reveal-config-reveal-map-bindings () + "Normal: each presentation command is reachable under `cj/reveal-map'." + (dolist (pair '(("SPC" . cj/reveal-present) + ("e" . cj/reveal-export) + ("p" . cj/reveal-preview-start) + ("s" . cj/reveal-preview-stop) + ("h" . cj/reveal-insert-header) + ("H" . cj/reveal-remove-headers) + ("n" . cj/reveal-new))) + (should (eq (keymap-lookup cj/reveal-map (car pair)) (cdr pair))))) + +(ert-deftest test-org-reveal-config-reveal-map-registered-under-p () + "Normal: `cj/reveal-map' is registered under \"p\" in `cj/custom-keymap'." + (should (eq (keymap-lookup cj/custom-keymap "p") cj/reveal-map))) + +(provide 'test-org-reveal-config-keymap) +;;; test-org-reveal-config-keymap.el ends here diff --git a/tests/test-org-roam-config-tag-and-find.el b/tests/test-org-roam-config-tag-and-find.el index f98d8af0..97a7a683 100644 --- a/tests/test-org-roam-config-tag-and-find.el +++ b/tests/test-org-roam-config-tag-and-find.el @@ -147,6 +147,17 @@ ;; The 4th arg is the subdir (should (equal (nth 3 args) "recipes/")))) +(ert-deftest test-org-roam-find-node-project-delegates-to-find-node () + "Normal: `find-node-project' uses Project tag, 'p' key, project.org template." + (let ((args nil)) + (cl-letf (((symbol-function 'cj/org-roam-find-node) + (lambda (&rest a) (setq args a)))) + (cj/org-roam-find-node-project)) + (should (equal (car args) "Project")) + (should (equal (cadr args) "p")) + ;; The 3rd arg is the template file, under the canonical roam-dir/templates/. + (should (string-suffix-p "templates/project.org" (nth 2 args))))) + ;;; cj/org-roam-node-insert-immediate (ert-deftest test-org-roam-node-insert-immediate-rebinds-templates-and-calls-insert () diff --git a/tests/test-pdf-config--reading-palette.el b/tests/test-pdf-config--reading-palette.el new file mode 100644 index 00000000..6a02d838 --- /dev/null +++ b/tests/test-pdf-config--reading-palette.el @@ -0,0 +1,87 @@ +;;; test-pdf-config--reading-palette.el --- pdf reading-palette tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Pure-logic tests for the pdf-view reading-palette layer: name->colors +;; resolution, the shipped default and order, and the cycle (palettes, then the +;; no-palette state, wrapping). The live application (which drives +;; `pdf-view-midnight-minor-mode') is exercised in the daemon, not here. +;; +;; Requires pdf-config, which uses use-package for pdf-tools; `make test' runs +;; without the implicit package-initialize, so bootstrap `package' first (the +;; shared format-wiring helper). pdf-tools is loaded lazily (:defer t), so this +;; only needs the pure top-level helpers, not the pdf-view runtime. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) + +(format-test--ensure-packages-init) +(require 'pdf-config) + +(declare-function cj/pdf--reading-palette-colors "pdf-config" (name)) +(declare-function cj/pdf--next-reading-palette "pdf-config" (current names)) +(defvar cj/pdf-reading-palettes) +(defvar cj/pdf-reading-default-palette) + +;;; ------------------------ cj/pdf--reading-palette-colors -------------------- + +(ert-deftest test-pdf-reading-palette-colors-known () + "Normal: a known palette resolves to a (FG . BG) cons of two strings." + (let ((colors (cj/pdf--reading-palette-colors "dark"))) + (should (consp colors)) + (should (stringp (car colors))) + (should (stringp (cdr colors))))) + +(ert-deftest test-pdf-reading-palette-colors-unknown () + "Error: an unknown palette name resolves to nil." + (should-not (cj/pdf--reading-palette-colors "nope"))) + +(ert-deftest test-pdf-reading-palette-colors-nil () + "Boundary: a nil name (the no-palette state) resolves to nil." + (should-not (cj/pdf--reading-palette-colors nil))) + +;;; --------------------------- shipped default + order ------------------------ + +(ert-deftest test-pdf-reading-default-is-dark () + "Normal: a fresh PDF opens on the dark palette." + (should (equal cj/pdf-reading-default-palette "dark"))) + +(ert-deftest test-pdf-reading-order-is-dark-sepia-light () + "Normal: the shipped palette order is dark, then sepia, then light." + (should (equal (mapcar #'car cj/pdf-reading-palettes) + '("dark" "sepia" "light")))) + +;;; ------------------------- cj/pdf--next-reading-palette --------------------- + +(ert-deftest test-pdf-reading-next-palette-advances () + "Normal: cycles to the next palette in order." + (should (equal (cj/pdf--next-reading-palette "dark" '("dark" "sepia" "light")) + "sepia"))) + +(ert-deftest test-pdf-reading-next-palette-last-to-none () + "Boundary: the last palette cycles to the no-palette state (nil)." + (should-not (cj/pdf--next-reading-palette "light" '("dark" "sepia" "light")))) + +(ert-deftest test-pdf-reading-next-palette-none-to-first () + "Boundary: the no-palette state (nil) cycles to the first palette." + (should (equal (cj/pdf--next-reading-palette nil '("dark" "sepia" "light")) + "dark"))) + +(ert-deftest test-pdf-reading-next-palette-unknown-current-falls-to-first () + "Error: an unknown current palette falls back to the first." + (should (equal (cj/pdf--next-reading-palette "gone" '("dark" "sepia" "light")) + "dark"))) + +(ert-deftest test-pdf-reading-cycle-from-default () + "Normal: cycling from the default advances dark -> sepia -> light -> none -> dark." + (let ((names (mapcar #'car cj/pdf-reading-palettes))) + (should (equal (cj/pdf--next-reading-palette "dark" names) "sepia")) + (should (equal (cj/pdf--next-reading-palette "sepia" names) "light")) + (should-not (cj/pdf--next-reading-palette "light" names)) + (should (equal (cj/pdf--next-reading-palette nil names) "dark")))) + +(provide 'test-pdf-config--reading-palette) +;;; test-pdf-config--reading-palette.el ends here 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-lsp.el b/tests/test-prog-general-lsp.el new file mode 100644 index 00000000..e61e9a17 --- /dev/null +++ b/tests/test-prog-general-lsp.el @@ -0,0 +1,148 @@ +;;; test-prog-general-lsp.el --- LSP config + helper tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the LSP configuration in prog-general.el, the single owner of +;; generic LSP policy (prog-lsp.el was folded in and removed 2026-07-10). +;; +;; Two layers: +;; - Load-time invariants that hold the moment the config loads, before any +;; server starts: lsp-enable-remote stays nil (so TRAMP files don't auto-start +;; a slow LSP), and no mode accrues a duplicate lsp-deferred entry. +;; - The pure helpers cj/lsp--add-file-watch-ignored-extras and +;; cj/lsp--remove-eldoc-provider-global, exercised directly with Normal / +;; Boundary / Error cases. +;; +;; The quiet-UI :config defaults (snippet off, symbol highlighting off, +;; idle-delay 0.5, ...) are deferred to lsp-mode's own load (see the make-test +;; no-package-initialize note in CLAUDE.md), so they aren't asserted here; the +;; daemon verifies them. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'use-package) + +;; Declare lsp-mode's defcustom / eldoc's hook as special so `let' binds them +;; dynamically. Real definitions load only when lsp-mode / eldoc activate; in +;; the test environment these provide the value cells the helpers read through. +(defvar lsp-file-watch-ignored-directories nil) +(defvar eldoc-documentation-functions nil) + +(defun lsp-eldoc-function (&rest _args) + "Stub lsp-mode Eldoc function for tests.") + +(require 'prog-general) + +;;; Load-time invariants + +(ert-deftest test-prog-general-lsp-enable-remote-nil () + "Normal: lsp-enable-remote is nil so LSP never auto-starts on TRAMP files." + (should (boundp 'lsp-enable-remote)) + (should (null lsp-enable-remote))) + +(ert-deftest test-prog-general-lsp-no-duplicate-mode-hook () + "Boundary: a mode never holds more than one lsp-deferred entry. +The per-language modules add lsp-deferred to their own mode hooks; add-hook +dedups identical symbols, and this pins that invariant so a future non-symbol +\(lambda) addition that breaks it gets caught." + (dolist (hook '(c-mode-hook python-mode-hook go-ts-mode-hook)) + (when (boundp hook) + (should (>= 1 (cl-count 'lsp-deferred (symbol-value hook))))))) + +;;; File-watch ignore helper — Normal + +(ert-deftest test-prog-general-lsp-file-watch-adds-all-patterns () + "Normal: every entry from `cj/lsp-file-watch-ignored-extras' lands in the list." + (let ((lsp-file-watch-ignored-directories nil)) + (cj/lsp--add-file-watch-ignored-extras) + (should (= (length lsp-file-watch-ignored-directories) + (length cj/lsp-file-watch-ignored-extras))) + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (member pattern lsp-file-watch-ignored-directories))))) + +(ert-deftest test-prog-general-lsp-file-watch-extends-not-replaces () + "Normal: pre-existing entries (lsp-mode defaults) are preserved." + (let ((lsp-file-watch-ignored-directories + '("[/\\\\]\\.git\\'" "[/\\\\]\\.svn\\'" "[/\\\\]\\.idea\\'"))) + (cj/lsp--add-file-watch-ignored-extras) + (should (member "[/\\\\]\\.git\\'" lsp-file-watch-ignored-directories)) + (should (member "[/\\\\]\\.svn\\'" lsp-file-watch-ignored-directories)) + (should (member "[/\\\\]\\.idea\\'" lsp-file-watch-ignored-directories)) + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (member pattern lsp-file-watch-ignored-directories))))) + +(ert-deftest test-prog-general-lsp-file-watch-key-patterns-present () + "Normal: specific expected directory names appear in the constant." + (dolist (name '("node_modules" "target" "__pycache__" ".venv" "venv" + "dist" "coverage" "test-results" "playwright-report" + ".terraform" ".ruff_cache" ".pytest_cache" ".mypy_cache")) + (should (cl-some (lambda (p) (string-match-p (regexp-quote name) p)) + cj/lsp-file-watch-ignored-extras)))) + +;;; File-watch ignore helper — Boundary + +(ert-deftest test-prog-general-lsp-file-watch-idempotent () + "Boundary: calling twice leaves each pattern present exactly once." + (let ((lsp-file-watch-ignored-directories nil)) + (cj/lsp--add-file-watch-ignored-extras) + (cj/lsp--add-file-watch-ignored-extras) + (should (= (length lsp-file-watch-ignored-directories) + (length cj/lsp-file-watch-ignored-extras))) + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (= 1 (cl-count pattern lsp-file-watch-ignored-directories + :test #'equal)))))) + +(ert-deftest test-prog-general-lsp-file-watch-all-patterns-non-empty () + "Boundary: every pattern is a non-empty string." + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (stringp pattern)) + (should (not (string-empty-p pattern))))) + +(ert-deftest test-prog-general-lsp-file-watch-all-patterns-valid-regex () + "Boundary: every pattern compiles as a valid Emacs regex." + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (condition-case err + ;; string-match-p compiles the regex; invalid syntax raises invalid-regexp. + (string-match-p pattern "/some/sample/path") + (invalid-regexp + (ert-fail (format "Invalid regex %S: %s" + pattern (error-message-string err))))))) + +;;; File-watch ignore helper — Error + +(ert-deftest test-prog-general-lsp-file-watch-non-list-target () + "Error: non-list target value triggers `add-to-list' wrong-type-argument." + (let ((lsp-file-watch-ignored-directories "not-a-list")) + (should-error (cj/lsp--add-file-watch-ignored-extras) + :type 'wrong-type-argument))) + +;;; Eldoc provider helper + +(ert-deftest test-prog-general-lsp-eldoc-provider-removed-globally () + "Normal: remove lsp-mode's Eldoc provider from the global hook value. +The per-buffer removal this replaced raced lsp-mode's own buffer-local hook +population; removing globally before any LSP buffer attaches makes the absence +stick for every subsequent lsp-managed buffer." + (let ((eldoc-documentation-functions + (list #'lsp-eldoc-function 'eldoc-documentation-default))) + (cj/lsp--remove-eldoc-provider-global) + (should-not (memq #'lsp-eldoc-function eldoc-documentation-functions)) + (should (memq 'eldoc-documentation-default eldoc-documentation-functions)))) + +(ert-deftest test-prog-general-lsp-eldoc-provider-removal-idempotent () + "Boundary: re-running the removal after the provider is gone is a no-op." + (let ((eldoc-documentation-functions '(eldoc-documentation-default))) + (cj/lsp--remove-eldoc-provider-global) + (cj/lsp--remove-eldoc-provider-global) + (should (equal eldoc-documentation-functions + '(eldoc-documentation-default))))) + +(ert-deftest test-prog-general-lsp-no-obsolete-eldoc-hook-reference () + "Regression: prog-general should not reference obsolete `lsp-eldoc-hook'." + (with-temp-buffer + (insert-file-contents (expand-file-name "modules/prog-general.el" user-emacs-directory)) + (should-not (re-search-forward "\\_<lsp-eldoc-hook\\_>" nil t)))) + +(provide 'test-prog-general-lsp) +;;; test-prog-general-lsp.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-lsp--add-file-watch-ignored-extras.el b/tests/test-prog-lsp--add-file-watch-ignored-extras.el deleted file mode 100644 index 9b71cab8..00000000 --- a/tests/test-prog-lsp--add-file-watch-ignored-extras.el +++ /dev/null @@ -1,116 +0,0 @@ -;;; test-prog-lsp--add-file-watch-ignored-extras.el --- Tests for cj/lsp--add-file-watch-ignored-extras -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for cj/lsp--add-file-watch-ignored-extras in prog-lsp.el. -;; The function adds project-agnostic build/cache directory patterns to -;; `lsp-file-watch-ignored-directories' without replacing lsp-mode's -;; defaults. Patterns are sourced from `cj/lsp-file-watch-ignored-extras'. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -;; Declare lsp-mode's defcustom as a special variable so `let' binds it -;; dynamically. Real definition is lsp-mode's; loaded only when use-package -;; activates lsp-mode. In the test environment, this stub provides the value -;; cell `add-to-list' needs. -(defvar lsp-file-watch-ignored-directories nil) -(defvar eldoc-documentation-functions nil) - -(defun lsp-eldoc-function (&rest _args) - "Stub lsp-mode Eldoc function for tests.") - -(require 'prog-lsp) - -;;; Normal Cases - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-normal-adds-all-patterns () - "Normal: every entry from `cj/lsp-file-watch-ignored-extras' lands in the list." - (let ((lsp-file-watch-ignored-directories nil)) - (cj/lsp--add-file-watch-ignored-extras) - (should (= (length lsp-file-watch-ignored-directories) - (length cj/lsp-file-watch-ignored-extras))) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (member pattern lsp-file-watch-ignored-directories))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-normal-extends-not-replaces () - "Normal: pre-existing entries (lsp-mode defaults) are preserved." - (let ((lsp-file-watch-ignored-directories - '("[/\\\\]\\.git\\'" "[/\\\\]\\.svn\\'" "[/\\\\]\\.idea\\'"))) - (cj/lsp--add-file-watch-ignored-extras) - (should (member "[/\\\\]\\.git\\'" lsp-file-watch-ignored-directories)) - (should (member "[/\\\\]\\.svn\\'" lsp-file-watch-ignored-directories)) - (should (member "[/\\\\]\\.idea\\'" lsp-file-watch-ignored-directories)) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (member pattern lsp-file-watch-ignored-directories))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-normal-key-patterns-present () - "Normal: specific expected directory names appear in the constant." - (dolist (name '("node_modules" "target" "__pycache__" ".venv" "venv" - "dist" "coverage" "test-results" "playwright-report" - ".terraform" ".ruff_cache" ".pytest_cache" ".mypy_cache")) - (should (cl-some (lambda (p) (string-match-p (regexp-quote name) p)) - cj/lsp-file-watch-ignored-extras)))) - -;;; Boundary Cases - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-boundary-idempotent () - "Boundary: calling twice doesn't duplicate entries." - (let ((lsp-file-watch-ignored-directories nil)) - (cj/lsp--add-file-watch-ignored-extras) - (cj/lsp--add-file-watch-ignored-extras) - (should (= (length lsp-file-watch-ignored-directories) - (length cj/lsp-file-watch-ignored-extras))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-boundary-all-patterns-non-empty () - "Boundary: every pattern is a non-empty string." - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (stringp pattern)) - (should (not (string-empty-p pattern))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-boundary-all-patterns-valid-regex () - "Boundary: every pattern compiles as a valid Emacs regex." - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (condition-case err - ;; string-match-p compiles the regex; invalid syntax raises invalid-regexp. - (string-match-p pattern "/some/sample/path") - (invalid-regexp - (ert-fail (format "Invalid regex %S: %s" - pattern (error-message-string err))))))) - -;;; Error Cases - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-error-non-list-target () - "Error: non-list target value triggers `add-to-list' wrong-type-argument." - (let ((lsp-file-watch-ignored-directories "not-a-list")) - (should-error (cj/lsp--add-file-watch-ignored-extras) - :type 'wrong-type-argument))) - -(ert-deftest test-prog-lsp--remove-eldoc-provider-global-removes-from-default () - "Normal: remove lsp-mode's Eldoc provider from the global hook value. -The per-buffer removal that this replaced raced lsp-mode's own buffer- -local hook population; removing globally before any LSP buffer attaches -makes the absence stick for every subsequent lsp-managed buffer." - (let ((eldoc-documentation-functions - '(lsp-eldoc-function eldoc-documentation-default))) - (cj/lsp--remove-eldoc-provider-global) - (should-not (memq #'lsp-eldoc-function eldoc-documentation-functions)) - (should (memq 'eldoc-documentation-default eldoc-documentation-functions)))) - -(ert-deftest test-prog-lsp--remove-eldoc-provider-global-is-idempotent () - "Boundary: re-running the removal after the provider is gone is a no-op." - (let ((eldoc-documentation-functions '(eldoc-documentation-default))) - (cj/lsp--remove-eldoc-provider-global) - (cj/lsp--remove-eldoc-provider-global) - (should (equal eldoc-documentation-functions - '(eldoc-documentation-default))))) - -(ert-deftest test-prog-lsp--module-no-obsolete-lsp-eldoc-hook-reference () - "Regression: prog-lsp should not reference obsolete `lsp-eldoc-hook'." - (with-temp-buffer - (insert-file-contents (expand-file-name "modules/prog-lsp.el" user-emacs-directory)) - (should-not (re-search-forward "\\_<lsp-eldoc-hook\\_>" nil t)))) - -(provide 'test-prog-lsp--add-file-watch-ignored-extras) -;;; test-prog-lsp--add-file-watch-ignored-extras.el ends here diff --git a/tests/test-prog-lsp.el b/tests/test-prog-lsp.el deleted file mode 100644 index 7e38111d..00000000 --- a/tests/test-prog-lsp.el +++ /dev/null @@ -1,66 +0,0 @@ -;;; test-prog-lsp.el --- Startup smoke test for LSP config resolution -*- lexical-binding: t; -*- - -;;; Commentary: -;; A narrow smoke test of prog-lsp.el, the central LSP module. It pins the -;; invariants that should hold the moment the config loads, before any server -;; starts: lsp-enable-remote stays nil (so TRAMP files don't auto-start a slow -;; LSP), the file-watch-ignore defaults live in one idempotent place, the eldoc -;; provider is stripped from the global hook, and a mode never accrues a -;; duplicate lsp-deferred entry. The generic :config defaults are deferred to -;; lsp-mode's own load (see the make-test no-package-initialize note in -;; CLAUDE.md), so this tests the top-level :init and helper surface, which runs. - -;;; Code: - -(require 'ert) -(require 'cl-lib) -(require 'use-package) -(require 'prog-lsp) - -;; lsp-mode's defcustom isn't loaded under make test, and prog-lsp's bare -;; `(defvar lsp-file-watch-ignored-directories)' only marks it special within -;; that file's unit. Declare it special here too so the `let' bindings below -;; bind dynamically (the helper reads it through the symbol via add-to-list). -(defvar lsp-file-watch-ignored-directories nil) - -(ert-deftest test-prog-lsp-enable-remote-nil () - "Normal: lsp-enable-remote is nil so LSP never auto-starts on TRAMP files." - (should (boundp 'lsp-enable-remote)) - (should (null lsp-enable-remote))) - -(ert-deftest test-prog-lsp-file-watch-adds-extras () - "Normal: the build/cache ignore patterns get appended to lsp's watch-ignore list." - (let ((lsp-file-watch-ignored-directories '("[/\\\\]\\.git\\'"))) - (cj/lsp--add-file-watch-ignored-extras) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (member pattern lsp-file-watch-ignored-directories))) - (should (member "[/\\\\]\\.git\\'" lsp-file-watch-ignored-directories)))) - -(ert-deftest test-prog-lsp-file-watch-idempotent () - "Boundary: adding the extras twice leaves each pattern present exactly once." - (let ((lsp-file-watch-ignored-directories '())) - (cj/lsp--add-file-watch-ignored-extras) - (cj/lsp--add-file-watch-ignored-extras) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (= 1 (cl-count pattern lsp-file-watch-ignored-directories - :test #'equal)))))) - -(ert-deftest test-prog-lsp-eldoc-provider-removed-globally () - "Normal: the global eldoc provider is stripped so lsp can't reattach it." - (let ((eldoc-documentation-functions - (list #'lsp-eldoc-function #'ignore))) - (cj/lsp--remove-eldoc-provider-global) - (should-not (memq 'lsp-eldoc-function eldoc-documentation-functions)) - (should (memq 'ignore eldoc-documentation-functions)))) - -(ert-deftest test-prog-lsp-no-duplicate-mode-hook () - "Boundary: a mode prog-lsp wires never holds more than one lsp-deferred entry. -prog-lsp and the per-language modules both add lsp-deferred for some modes; -add-hook dedups identical symbols, and this pins that invariant so a future -non-symbol (lambda) addition that breaks it gets caught." - (dolist (hook '(c-mode-hook python-mode-hook go-ts-mode-hook)) - (when (boundp hook) - (should (>= 1 (cl-count 'lsp-deferred (symbol-value hook))))))) - -(provide 'test-prog-lsp) -;;; test-prog-lsp.el ends here diff --git a/tests/test-prog-python--lsp-guard.el b/tests/test-prog-python--lsp-guard.el new file mode 100644 index 00000000..071e1ca9 --- /dev/null +++ b/tests/test-prog-python--lsp-guard.el @@ -0,0 +1,64 @@ +;;; test-prog-python--lsp-guard.el --- Python LSP guard tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found lsp-pyright's unguarded :hook lambda calling +;; (require 'lsp-pyright) + (lsp-deferred) on every python-ts buffer, so +;; pyright-less machines got the LSP attach prompt that cj/python-setup's +;; guard exists to prevent. The guarded branch now owns the require and +;; the attach, and both classic and treesit modes run the same setup. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-python) + +(defmacro test-python-guard--setup (pyright-found &rest body) + "Run `cj/python-setup' with pyright presence set to PYRIGHT-FOUND. +Records requires into `required' and lsp attaches into `attached'; +BODY sees both. Package minor modes are stubbed at their boundary." + (declare (indent 1)) + `(let ((required '()) (attached nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'executable-find) + (lambda (&rest _) ,pyright-found)) + ((symbol-function 'require) + (lambda (feature &rest _) (push feature required) feature)) + ((symbol-function 'lsp-deferred) + (lambda () (setq attached t)))) + (with-temp-buffer + (cj/python-setup)) + ,@body))) + +(ert-deftest test-prog-python-setup-pyright-absent-no-lsp () + "Error: without pyright, setup neither loads lsp-pyright nor attaches." + (test-python-guard--setup nil + (should-not (memq 'lsp-pyright required)) + (should-not attached))) + +(ert-deftest test-prog-python-setup-pyright-present-attaches () + "Normal: with pyright on PATH, setup loads lsp-pyright then attaches." + (test-python-guard--setup "/usr/bin/pyright" + (should (memq 'lsp-pyright required)) + (should attached))) + +(ert-deftest test-prog-python-hooks-cover-both-mode-variants () + "Normal: classic and treesit python modes both run the same setup." + (dolist (hook '(python-mode-hook python-ts-mode-hook)) + (should (memq #'cj/python-setup (symbol-value hook))) + (should (memq #'cj/python-mode-keybindings (symbol-value hook))))) + +(ert-deftest test-prog-python-no-anonymous-hook-lambdas () + "Boundary: no anonymous lambda remains on the python hooks. +The audit's unguarded lsp-pyright lambda was anonymous; symbols only +means every hook entry is a named, greppable function." + (dolist (hook '(python-mode-hook python-ts-mode-hook)) + (dolist (fn (symbol-value hook)) + (should (symbolp fn))))) + +(provide 'test-prog-python--lsp-guard) +;;; test-prog-python--lsp-guard.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-show-kill-ring--insert-item.el b/tests/test-show-kill-ring--insert-item.el deleted file mode 100644 index a29ca75e..00000000 --- a/tests/test-show-kill-ring--insert-item.el +++ /dev/null @@ -1,73 +0,0 @@ -;;; test-show-kill-ring--insert-item.el --- Tests for show-kill-insert-item -*- lexical-binding: t -*- - -;;; Commentary: -;; Tests for `show-kill-insert-item' in show-kill-ring.el — inserts a -;; kill-ring entry into the current buffer, truncating to -;; `show-kill-max-item-size' with an ellipsis when too long. The ellipsis -;; sits inline for short items and on its own line for items wider than the -;; frame. Frame width is read at runtime so the test is environment-stable. - -;;; Code: - -(require 'ert) -(require 'show-kill-ring) - -;;; Normal Cases - -(ert-deftest test-show-kill-ring-insert-item-short-verbatim () - "Normal: an item shorter than the max is inserted unchanged." - (let ((show-kill-max-item-size 1000)) - (with-temp-buffer - (show-kill-insert-item "hello") - (should (string= (buffer-string) "hello"))))) - -(ert-deftest test-show-kill-ring-insert-item-inline-ellipsis () - "Normal: an over-max item narrower than the frame gets an inline ellipsis." - (let* ((show-kill-max-item-size 5) - (len (/ (frame-width) 2)) ; > max, < (frame-width - 5) - (item (make-string len ?b))) - (with-temp-buffer - (show-kill-insert-item item) - (should (string= (buffer-string) "bbbbb..."))))) - -;;; Boundary Cases - -(ert-deftest test-show-kill-ring-insert-item-length-equals-max-truncates () - "Boundary: length exactly equal to max truncates — the guard is (< len max)." - (let ((show-kill-max-item-size 5)) - (with-temp-buffer - (show-kill-insert-item "hello") ; length 5, equals max - (should (string= (buffer-string) "hello..."))))) - -(ert-deftest test-show-kill-ring-insert-item-wide-newline-ellipsis () - "Boundary: an item wider than the frame puts the ellipsis on its own line." - (let* ((show-kill-max-item-size 5) - (item (make-string (+ (frame-width) 10) ?a))) - (with-temp-buffer - (show-kill-insert-item item) - (should (string= (buffer-string) "aaaaa\n..."))))) - -(ert-deftest test-show-kill-ring-insert-item-max-nil-verbatim () - "Boundary: a non-numeric max disables truncation." - (let ((show-kill-max-item-size nil)) - (with-temp-buffer - (show-kill-insert-item "anything long enough to exceed nothing") - (should (string= (buffer-string) - "anything long enough to exceed nothing"))))) - -(ert-deftest test-show-kill-ring-insert-item-max-negative-verbatim () - "Boundary: a negative max disables truncation." - (let ((show-kill-max-item-size -1)) - (with-temp-buffer - (show-kill-insert-item "abc") - (should (string= (buffer-string) "abc"))))) - -(ert-deftest test-show-kill-ring-insert-item-empty-string () - "Boundary: an empty item inserts nothing and does not error." - (let ((show-kill-max-item-size 1000)) - (with-temp-buffer - (show-kill-insert-item "") - (should (string= (buffer-string) ""))))) - -(provide 'test-show-kill-ring--insert-item) -;;; test-show-kill-ring--insert-item.el ends here diff --git a/tests/test-signal-config-notify.el b/tests/test-signal-config-notify.el deleted file mode 100644 index 1a772289..00000000 --- a/tests/test-signal-config-notify.el +++ /dev/null @@ -1,150 +0,0 @@ -;;; test-signal-config-notify.el --- Tests for the signal-config notification slice -*- lexical-binding: t -*- - -;;; Commentary: -;; ERT tests for the notification slice of `signal-config': the pure -;; body formatter (whitespace collapse + truncation to -;; `cj/signal--notify-body-max') and `cj/signel--notify' routing (the -;; suppression gate, the notify-script path with the sound flag, and -;; the `notifications-notify' fallback). Spec: the "Notification -;; slice" addendum in docs/specs/signal-client-spec-doing.org. No signal-cli or -;; linked account needed. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -;; signel is the fork at ~/code/signel; signal-config wires it via -;; use-package but these tests need the symbols available directly. -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(require 'signal-config) - -;;; cj/signal--format-notify-body - -(ert-deftest test-signal-config-format-notify-body-passthrough () - "Normal: short single-line text passes through unchanged." - (should (equal (cj/signal--format-notify-body "lunch at noon?") - "lunch at noon?"))) - -(ert-deftest test-signal-config-format-notify-body-collapses-whitespace () - "Normal: newlines and whitespace runs collapse to single spaces." - (should (equal (cj/signal--format-notify-body "two\nlines\n\nhere") - "two lines here")) - (should (equal (cj/signal--format-notify-body "tabs\t\tand spaces") - "tabs and spaces"))) - -(ert-deftest test-signal-config-format-notify-body-trims () - "Boundary: leading and trailing whitespace is trimmed." - (should (equal (cj/signal--format-notify-body " hi ") "hi"))) - -(ert-deftest test-signal-config-format-notify-body-empty () - "Boundary: the empty string stays empty." - (should (equal (cj/signal--format-notify-body "") ""))) - -(ert-deftest test-signal-config-format-notify-body-exact-limit () - "Boundary: a body exactly at the limit is untouched." - (let ((s (make-string cj/signal--notify-body-max ?x))) - (should (equal (cj/signal--format-notify-body s) s)))) - -(ert-deftest test-signal-config-format-notify-body-truncates-over-limit () - "Boundary: over-limit text truncates to the limit, ending in an ellipsis." - (let* ((s (make-string (1+ cj/signal--notify-body-max) ?x)) - (out (cj/signal--format-notify-body s))) - (should (= (length out) cj/signal--notify-body-max)) - (should (string-suffix-p "…" out)))) - -(ert-deftest test-signal-config-format-notify-body-unicode () - "Boundary: multibyte text truncates by characters, not bytes." - (let* ((s (make-string (+ cj/signal--notify-body-max 10) ?é)) - (out (cj/signal--format-notify-body s))) - (should (= (length out) cj/signal--notify-body-max)) - (should (string-suffix-p "…" out)))) - -;;; cj/signel--notify routing - -(ert-deftest test-signal-config-notify-suppressed-when-viewing () - "Normal: nothing fires when the suppression predicate says no." - (let (script-calls fallback-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) nil)) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil)) - ((symbol-function 'notifications-notify) - (lambda (&rest args) (push args fallback-calls) nil))) - (cj/signel--notify "+15551234567" "Alice" "hi")) - (should-not script-calls) - (should-not fallback-calls))) - -(ert-deftest test-signal-config-notify-script-silent-by-default () - "Normal: with the script present and sound off, runs notify info --silent." - (let (script-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (p &optional _remote) - (when (equal p "notify") "/usr/bin/notify"))) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil)) - ((symbol-function 'notifications-notify) - (lambda (&rest _) - (error "Fallback must not fire when the script is present")))) - (let ((cj/signel-notify-sound nil)) - (cj/signel--notify "+15551234567" "Alice" "hi"))) - (should (= (length script-calls) 1)) - ;; start-process args: (NAME BUFFER PROGRAM &rest PROGRAM-ARGS); - ;; PROGRAM is the path executable-find resolved, not the bare name. - (should (equal (nthcdr 2 (car script-calls)) - '("/usr/bin/notify" "info" "Signal: Alice" "hi" "--silent"))))) - -(ert-deftest test-signal-config-notify-sound-enabled-drops-silent () - "Normal: with `cj/signel-notify-sound' non-nil, --silent is omitted." - (let (script-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (p &optional _remote) - (when (equal p "notify") "/usr/bin/notify"))) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil))) - (let ((cj/signel-notify-sound t)) - (cj/signel--notify "+15551234567" "Alice" "hi"))) - (should (equal (nthcdr 2 (car script-calls)) - '("/usr/bin/notify" "info" "Signal: Alice" "hi"))))) - -(ert-deftest test-signal-config-notify-fallback-when-script-missing () - "Error: without the script on PATH, falls back to notifications-notify." - (let (script-calls fallback-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (_p &optional _remote) nil)) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil)) - ((symbol-function 'notifications-notify) - (lambda (&rest args) (push args fallback-calls) nil))) - (cj/signel--notify "+15551234567" "Alice" "hi")) - (should-not script-calls) - (should (= (length fallback-calls) 1)) - (let ((args (car fallback-calls))) - (should (equal (plist-get args :title) "Signal: Alice")) - (should (equal (plist-get args :body) "hi"))))) - -(ert-deftest test-signal-config-notify-formats-body-before-send () - "Normal: the body runs through the formatter before reaching the script." - (let (script-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (p &optional _remote) - (when (equal p "notify") "/usr/bin/notify"))) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil))) - (let ((cj/signel-notify-sound nil)) - (cj/signel--notify "+15551234567" "Alice" "first line\nsecond line"))) - (should (equal (nth 5 (car script-calls)) "first line second line")))) - -(provide 'test-signal-config-notify) -;;; test-signal-config-notify.el ends here diff --git a/tests/test-signal-config.el b/tests/test-signal-config.el deleted file mode 100644 index 7556efdb..00000000 --- a/tests/test-signal-config.el +++ /dev/null @@ -1,407 +0,0 @@ -;;; test-signal-config.el --- Tests for signal-config -*- lexical-binding: t -*- - -;;; Commentary: -;; ERT tests for the pure helper layer of `signal-config': contact-list -;; parsing for the contact picker, and the notify-when-not-viewing -;; predicate. These need neither signal-cli nor a linked account. - -;;; Code: - -(require 'ert) -(require 'cl-lib) -(require 'json) - -;; signel is the fork at ~/code/signel; signal-config wires it via -;; use-package but the connection-guard/fetch tests need the symbols -;; available directly. -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(require 'signal-config) - -;;; cj/signal--jstr - -(ert-deftest test-signal-config-jstr-string () - "Normal: a non-blank string passes through unchanged." - (should (equal (cj/signal--jstr "hi") "hi"))) - -(ert-deftest test-signal-config-jstr-rejects-nonstrings () - "Boundary/Error: nil, empty, whitespace, and non-string sentinels become nil." - (should-not (cj/signal--jstr nil)) - (should-not (cj/signal--jstr "")) - (should-not (cj/signal--jstr " ")) - (should-not (cj/signal--jstr :null)) - (should-not (cj/signal--jstr 42))) - -;;; cj/signal--contact-display-name -;; Field priority: nickName, then nickGiven+nickFamily, then top-level name, -;; then top-level given+family, then profile given+family, then username. - -(ert-deftest test-signal-config-display-name-prefers-name () - "Normal: the top-level combined name wins over the given/family parts." - (should (equal (cj/signal--contact-display-name - '((name . "Alice Anderson") (givenName . "Ali") (familyName . "A"))) - "Alice Anderson"))) - -(ert-deftest test-signal-config-display-name-nickname-wins () - "Normal: a nickName overrides the contact name." - (should (equal (cj/signal--contact-display-name - '((nickName . "Edster") (name . "Eve Edwards") - (givenName . "Eve") (familyName . "Edwards"))) - "Edster"))) - -(ert-deftest test-signal-config-display-name-nickname-parts () - "Boundary: nickGivenName+nickFamilyName combine when nickName is unset." - (should (equal (cj/signal--contact-display-name - '((nickGivenName . "DJ") (nickFamilyName . "Cool") (name . "Daniel"))) - "DJ Cool"))) - -(ert-deftest test-signal-config-display-name-toplevel-given-family () - "Boundary: with no name, top-level givenName+familyName combine." - (should (equal (cj/signal--contact-display-name - '((name) (givenName . "Bob") (familyName . "Brown"))) - "Bob Brown"))) - -(ert-deftest test-signal-config-display-name-profile-fallback () - "Boundary: with no name or top-level parts, profile given/family is the fallback." - (should (equal (cj/signal--contact-display-name - '((name) (givenName) (familyName) - (profile . ((givenName . "Carol") (familyName))))) - "Carol"))) - -(ert-deftest test-signal-config-display-name-username-fallback () - "Boundary: username is the last name source." - (should (equal (cj/signal--contact-display-name - '((name) (username . "dave.42"))) - "dave.42"))) - -(ert-deftest test-signal-config-display-name-none () - "Error: no usable name yields nil." - (should-not (cj/signal--contact-display-name - '((name) (givenName) (familyName) - (profile . ((givenName) (familyName)))))) - (should-not (cj/signal--contact-display-name '((number . "+15551112222"))))) - -;;; cj/signal--parse-contacts - -(defconst test-signal-config--contacts-json - "[ - {\"number\":\"+15551112222\",\"uuid\":\"uuid-a\",\"name\":\"Alice Anderson\",\"givenName\":\"Alice\",\"familyName\":\"Anderson\",\"nickName\":null,\"nickGivenName\":null,\"nickFamilyName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, - {\"number\":\"+15553334444\",\"uuid\":null,\"name\":null,\"givenName\":\"Bob\",\"familyName\":\"Brown\",\"nickName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, - {\"number\":\"+15555556666\",\"uuid\":\"uuid-c\",\"name\":null,\"givenName\":null,\"familyName\":null,\"nickName\":null,\"username\":null,\"profile\":{\"givenName\":\"Carol\",\"familyName\":null}}, - {\"number\":null,\"uuid\":\"uuid-d\",\"name\":null,\"givenName\":null,\"familyName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, - {\"number\":\"+15557778888\",\"uuid\":\"uuid-e\",\"name\":\"Eve Edwards\",\"givenName\":\"Eve\",\"familyName\":\"Edwards\",\"nickName\":\"Edster\",\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}} -]" - "Synthetic fixture mirroring the signal-cli 0.14.4.1 `listContacts' shape: -top-level name/givenName/familyName and nickName fields, with a profile -sub-object whose name fields are usually null. Field layout was confirmed -against a live linked account on 2026-05-26; the values here are fake.") - -(ert-deftest test-signal-config-parse-contacts-normal () - "Normal: top-level name, top-level parts, profile fallback, uuid fallback, nickname." - (let* ((result (json-read-from-string test-signal-config--contacts-json)) - (pairs (cj/signal--parse-contacts result))) - (should (equal pairs - '(("Alice Anderson (+15551112222)" . "+15551112222") - ("Bob Brown (+15553334444)" . "+15553334444") - ("Carol (+15555556666)" . "+15555556666") - ("Edster (+15557778888)" . "+15557778888") - ("uuid-d" . "uuid-d")))))) - -(ert-deftest test-signal-config-parse-contacts-empty () - "Boundary: an empty result yields nil for both vector and nil input." - (should-not (cj/signal--parse-contacts [])) - (should-not (cj/signal--parse-contacts nil))) - -(ert-deftest test-signal-config-parse-contacts-accepts-list-and-vector () - "Boundary: vector and list result sequences parse identically." - (let ((entry '((number . "+15551112222") (name . "Al")))) - (should (equal (cj/signal--parse-contacts (vector entry)) - (cj/signal--parse-contacts (list entry)))))) - -(ert-deftest test-signal-config-parse-contacts-drops-recipientless () - "Error: a contact with neither number nor uuid is dropped." - (should-not (cj/signal--parse-contacts - (list '((name . "Ghost") (number) (uuid)))))) - -;;; cj/signal--suppress-notify-p - -(ert-deftest test-signal-config-suppress-when-viewing-focused () - "Normal: viewing the chat buffer with focus suppresses the notification." - (should (cj/signal--suppress-notify-p - "+15551112222" "*Signel: +15551112222*" t))) - -(ert-deftest test-signal-config-no-suppress-other-buffer () - "Boundary: a different selected buffer does not suppress." - (should-not (cj/signal--suppress-notify-p - "+15551112222" "*scratch*" t))) - -(ert-deftest test-signal-config-no-suppress-unfocused () - "Boundary: viewing the chat but with the frame unfocused still notifies." - (should-not (cj/signal--suppress-notify-p - "+15551112222" "*Signel: +15551112222*" nil))) - -(ert-deftest test-signal-config-no-suppress-nil-viewing () - "Error: a nil viewing-buffer name does not suppress." - (should-not (cj/signal--suppress-notify-p "+15551112222" nil t))) - -;;; cj/signel--ensure-started - -(ert-deftest test-signal-config-ensure-started-live-process-noop () - "Normal: with a live signel process, ensure-started returns without -calling `signel-start' or the pre-warm fetch." - (let ((start-called nil) - (fetch-called nil)) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) - ((symbol-function 'get-process) (lambda (_) 'fake-proc)) - ((symbol-function 'signel-start) - (lambda () (setq start-called t))) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) (setq fetch-called t)))) - (cj/signel--ensure-started) - (should-not start-called) - (should-not fetch-called)))) - -(ert-deftest test-signal-config-ensure-started-starts-when-account-set () - "Normal: with `signel-account' set and no live process, ensure-started -calls `signel-start' to bring the daemon up." - (let ((start-called nil) - (signel-account "+15555550100")) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'get-process) (lambda (_) nil)) - ((symbol-function 'signel-start) - (lambda () (setq start-called t))) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) nil))) - (cj/signel--ensure-started) - (should start-called)))) - -(ert-deftest test-signal-config-ensure-started-prewarms-on-start () - "Normal: when ensure-started actually starts the daemon, it triggers a -pre-warm fetch so the picker cache is warm on first invocation." - (let ((fetch-called nil) - (signel-account "+15555550100")) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'get-process) (lambda (_) nil)) - ((symbol-function 'signel-start) (lambda () nil)) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) (setq fetch-called t)))) - (cj/signel--ensure-started) - (should fetch-called)))) - -(ert-deftest test-signal-config-ensure-started-errors-when-no-account () - "Error: with `signel-account' nil, ensure-started signals a user-error -naming the remedy (set the account in the private config) instead of -starting an account-less daemon." - (let ((signel-account nil)) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'get-process) (lambda (_) nil))) - (should-error (cj/signel--ensure-started) :type 'user-error)))) - -(ert-deftest test-signal-config-ensure-started-requires-signel-first () - "Error: ensure-started must `require' signel BEFORE reading any of -its private variables, so a `void-variable' error cannot fire when -called before signel has been autoloaded. Captures the bug where -`signel--process-name' was forward-declared in signal-config but not -yet bound at runtime because the `use-package' autoload had not fired. - -Asserts ordering, not just presence: a future refactor that moves the -`require' below the `cond' would still execute the require eventually -but the variable read in the cond would fire void-variable first. -The test fails if `require' isn't the first call inside the function." - (let ((call-order nil)) - (cl-letf (((symbol-function 'require) - (lambda (feature &optional _filename _noerror) - (push (list 'require feature) call-order) - t)) - ((symbol-function 'process-live-p) - (lambda (_) (push 'process-live-p call-order) t)) - ((symbol-function 'get-process) - (lambda (_) (push 'get-process call-order) 'fake-proc))) - (cj/signel--ensure-started) - (should (equal (car (reverse call-order)) '(require signel)))))) - -;;; cj/signel--fetch-contacts + cj/signel--contact-cache - -(ert-deftest test-signal-config-fetch-contacts-issues-list-contacts-rpc () - "Normal: fetch-contacts sends a `listContacts' RPC and registers a -success callback so the response routes back." - (let (sent-method sent-callback) - (cl-letf (((symbol-function 'signel--send-rpc) - (lambda (method _params _target callback) - (setq sent-method method - sent-callback callback) - 1))) - (cj/signel--fetch-contacts)) - (should (equal sent-method "listContacts")) - (should (functionp sent-callback)))) - -(ert-deftest test-signal-config-fetch-contacts-callback-populates-cache () - "Normal: on a successful result, the callback parses the contact list -and stores the (LABEL . RECIPIENT) alist in `cj/signel--contact-cache'." - (let (sent-callback) - (cl-letf (((symbol-function 'signel--send-rpc) - (lambda (_method _params _target callback) - (setq sent-callback callback) 1))) - (setq cj/signel--contact-cache nil) - (cj/signel--fetch-contacts) - (funcall sent-callback - [((number . "+15555550100") (givenName . "Alice"))])) - (should (equal cj/signel--contact-cache - '(("Alice (+15555550100)" . "+15555550100")))))) - -(ert-deftest test-signal-config-fetch-contacts-empty-result-clears-cache () - "Boundary: an empty listContacts result populates the cache as nil, -distinct from a failure path (which never invokes the success callback)." - (let (sent-callback) - (cl-letf (((symbol-function 'signel--send-rpc) - (lambda (_method _params _target callback) - (setq sent-callback callback) 1))) - (setq cj/signel--contact-cache '(("stale" . "+10000000000"))) - (cj/signel--fetch-contacts) - (funcall sent-callback [])) - (should-not cj/signel--contact-cache))) - -;;; cj/signel-refresh-contacts - -(ert-deftest test-signal-config-refresh-contacts-clears-and-refetches () - "Normal: `cj/signel-refresh-contacts' clears the cache and triggers a -fresh fetch so a stale entry can't survive a user-driven refresh." - (let ((fetch-called nil)) - (setq cj/signel--contact-cache '(("stale" . "+10000000000"))) - (cl-letf (((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) (setq fetch-called t)))) - (cj/signel-refresh-contacts)) - (should-not cj/signel--contact-cache) - (should fetch-called))) - -;;; cj/signel-message picker - -(ert-deftest test-signal-config-message-warm-cache-picks-contact () - "Normal: with a warm cache, picking a contact label opens that -recipient's chat buffer." - (let ((chosen-recipient nil) - (signel-account "+15555550100")) - (setq cj/signel--contact-cache - '(("Alice (+15555550200)" . "+15555550200"))) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'completing-read) - (lambda (&rest _) "Alice (+15555550200)")) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message)) - (should (equal chosen-recipient "+15555550200")))) - -(ert-deftest test-signal-config-message-warm-cache-picks-note-to-self () - "Normal: the pinned `Note to Self' entry resolves to `signel-account' -so a self-message lands in the Signal Note-to-Self thread." - (let ((chosen-recipient nil) - (signel-account "+15555550100")) - (setq cj/signel--contact-cache - '(("Alice (+15555550200)" . "+15555550200"))) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'completing-read) - (lambda (&rest _) "Note to Self")) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message)) - (should (equal chosen-recipient "+15555550100")))) - -(ert-deftest test-signal-config-message-cold-cache-fetch-resolves-in-time () - "Normal: cold cache, fetch's after-callback fires inside the bounded -wait, picker proceeds with the now-warm cache." - (let ((chosen-recipient nil) - (signel-account "+15555550100") - (cj/signel-fetch-timeout 1.0)) - (setq cj/signel--contact-cache nil) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&optional after-cb) - (setq cj/signel--contact-cache - '(("Bob (+15555550300)" . "+15555550300"))) - (when after-cb (funcall after-cb)))) - ((symbol-function 'completing-read) - (lambda (&rest _) "Bob (+15555550300)")) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message)) - (should (equal chosen-recipient "+15555550300")))) - -(ert-deftest test-signal-config-message-cold-cache-timeout-errors () - "Error: cold cache, fetch never resolves, picker user-errors before -the bounded wait would let Emacs hang on a dead daemon." - (let ((signel-account "+15555550100") - (cj/signel-fetch-timeout 0.1)) - (setq cj/signel--contact-cache nil) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) nil))) - (should-error (cj/signel-message) :type 'user-error)))) - -;;; cj/signel-message-self - -(ert-deftest test-signal-config-message-self-calls-signel-chat-with-account () - "Normal: the direct self-message command opens a chat buffer addressed -to `signel-account', skipping the picker entirely." - (let ((chosen-recipient nil) - (signel-account "+15555550100")) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message-self)) - (should (equal chosen-recipient "+15555550100")))) - -;;; cj/signel-prefix-map (C-; M) - -(ert-deftest test-signal-config-prefix-map-has-expected-bindings () - "Normal: the signel C-; M prefix map binds m / s / d / q / SPC to the -commands the workflow spec names." - (should (eq (keymap-lookup cj/signel-prefix-map "m") - #'cj/signel-message)) - (should (eq (keymap-lookup cj/signel-prefix-map "s") - #'cj/signel-message-self)) - (should (eq (keymap-lookup cj/signel-prefix-map "d") - #'signel-dashboard)) - (should (eq (keymap-lookup cj/signel-prefix-map "q") - #'signel-stop)) - (should (eq (keymap-lookup cj/signel-prefix-map "SPC") - #'cj/signel-connect))) - -(ert-deftest test-signal-config-prefix-map-registered-under-c-semi-m () - "Normal: loading signal-config registers `cj/signel-prefix-map' under -`M' in `cj/custom-keymap', so C-; M reaches the signel prefix. Guards -the wiring contract that the load-order bug broke: signal-config must -register through `cj/register-prefix-map', not a boundp-guarded direct -mutation that silently no-ops when keybindings loaded in a different -order." - (require 'keybindings) - (should (eq (keymap-lookup cj/custom-keymap "M") cj/signel-prefix-map))) - -;;; display-buffer-alist entry for *Signel: ...* chat buffers - -(ert-deftest test-signal-config-chat-buffer-display-rule-uses-bottom-30 () - "Normal: signal-config registers a `display-buffer-alist' entry that -matches `*Signel: <id>*' buffers, routes them through -`display-buffer-at-bottom', and sets `window-height' to 0.3 so the -chat docks to the bottom 30% of the frame." - (let ((entry (seq-find (lambda (e) (equal (car e) "\\`\\*Signel: ")) - display-buffer-alist))) - (should entry) - (should (memq 'display-buffer-at-bottom (cadr entry))) - (should (equal 0.3 (cdr (assq 'window-height (cddr entry))))))) - -(ert-deftest test-signal-config-chat-buffer-display-rule-matches-buffer-name () - "Boundary: the registered regex matches a realistic chat buffer name -\(phone-number id and group-id) and does not match unrelated buffers." - (let* ((entry (seq-find (lambda (e) (equal (car e) "\\`\\*Signel: ")) - display-buffer-alist)) - (regex (car entry))) - (should regex) - (should (string-match-p regex "*Signel: +15555550100*")) - (should (string-match-p regex "*Signel: groupid-abc*")) - (should-not (string-match-p regex "*signel-log*")) - (should-not (string-match-p regex "scratch")))) - -(provide 'test-signal-config) -;;; test-signal-config.el ends here diff --git a/tests/test-signel-cancel-input.el b/tests/test-signel-cancel-input.el deleted file mode 100644 index b2a7ef89..00000000 --- a/tests/test-signel-cancel-input.el +++ /dev/null @@ -1,74 +0,0 @@ -;;; test-signel-cancel-input.el --- Cancel-input contract for the signel fork -*- lexical-binding: t; -*- - -;;; Commentary: -;; `signel--cancel-input' is the C-c C-k handler in `signel-chat-mode'. -;; Its contract: clear any in-progress input between `signel--input-marker' -;; and `point-max' (so the prompt is fresh on next visit), then dismiss -;; the window via `quit-window' (the buffer stays alive so chat history -;; survives revisits). These tests lock the contract; the binding test -;; locks the keymap entry. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defmacro test-signel-cancel--with-chat-buffer (&rest body) - "Set up a temp signel-chat-mode buffer with prompt drawn and run BODY." - (declare (indent 0)) - `(with-temp-buffer - (signel-chat-mode) - (setq signel--chat-id "+15555550100") - (signel--draw-prompt) - ,@body)) - -(ert-deftest test-signel-cancel-input-clears-pending-text () - "Normal: pending input from input-marker to point-max is cleared." - (test-signel-cancel--with-chat-buffer - (insert "abandoned-draft") - (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) - (signel--cancel-input)) - (should-not (signel--pending-input)))) - -(ert-deftest test-signel-cancel-input-empty-input-area-is-a-noop () - "Boundary: cancelling with no in-progress input is harmless." - (test-signel-cancel--with-chat-buffer - (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) - (signel--cancel-input)) - (should-not (signel--pending-input)))) - -(ert-deftest test-signel-cancel-input-calls-quit-window () - "Normal: cancel dismisses the window via `quit-window'." - (test-signel-cancel--with-chat-buffer - (insert "abandoned-draft") - (let ((called nil)) - (cl-letf (((symbol-function 'quit-window) - (lambda (&rest _) (setq called t)))) - (signel--cancel-input)) - (should called)))) - -(ert-deftest test-signel-cancel-input-preserves-buffer () - "Normal: cancel does not kill the buffer; chat history (prompt + prior -content above the input marker) survives so reopening the contact lands -in the same buffer." - (test-signel-cancel--with-chat-buffer - (insert "abandoned-draft") - (let ((buf (current-buffer))) - (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) - (signel--cancel-input)) - (should (buffer-live-p buf))))) - -(ert-deftest test-signel-chat-mode-binds-c-c-c-k-to-cancel () - "Normal: `signel-chat-mode' binds C-c C-k to `signel--cancel-input' so -the documented cancel gesture reaches the handler." - (with-temp-buffer - (signel-chat-mode) - (should (eq (lookup-key (current-local-map) (kbd "C-c C-k")) - #'signel--cancel-input)))) - -(provide 'test-signel-cancel-input) -;;; test-signel-cancel-input.el ends here diff --git a/tests/test-signel-input-preservation.el b/tests/test-signel-input-preservation.el deleted file mode 100644 index e8ce4ddb..00000000 --- a/tests/test-signel-input-preservation.el +++ /dev/null @@ -1,68 +0,0 @@ -;;; test-signel-input-preservation.el --- Regression for signel #2 input clobber -*- lexical-binding: t; -*- - -;;; Commentary: -;; signel-chat-mode buffers have an editable prompt area starting at -;; `signel--input-marker'. Before this fix, both `signel--insert-msg' (the -;; receive path) and `signel--insert-system-msg' (the RPC-error path) -;; called `(delete-region (point) (point-max))' to clear the old prompt -;; before redrawing it, which destroyed any text the user was mid-typing. -;; -;; These tests lock the preservation contract: a small `signel--pending-input' -;; helper captures the in-progress input from the marker to `point-max', and -;; both inserters restore it after the freshly drawn prompt. The chat-mode -;; buffer is constructed in a temp buffer; `signel--insert-msg' is steered -;; to it via a stub on `signel--get-buffer'. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defmacro test-signel--with-chat-buffer (&rest body) - "Set up a temp signel-chat-mode buffer with prompt drawn and run BODY." - (declare (indent 0)) - `(with-temp-buffer - (signel-chat-mode) - (setq signel--chat-id "+15555550100") - (signel--draw-prompt) - ,@body)) - -(ert-deftest test-signel-input-pending-returns-typed-text () - "Normal: with text after the prompt marker, `signel--pending-input' -returns the captured text." - (test-signel--with-chat-buffer - (insert "halfwritten") - (should (equal (signel--pending-input) "halfwritten")))) - -(ert-deftest test-signel-input-pending-returns-nil-when-empty () - "Boundary: an empty input area returns nil so callers don't restore an -empty string after the prompt." - (test-signel--with-chat-buffer - (should-not (signel--pending-input)))) - -(ert-deftest test-signel-input-system-msg-preserves-pending-input () - "Regression for #2: `signel--insert-system-msg' redraws the prompt -without clobbering text the user was mid-typing." - (test-signel--with-chat-buffer - (insert "halfwritten") - (signel--insert-system-msg "An error happened" 'signel-error-face) - (should (string-match-p "An error happened" (buffer-string))) - (should (equal (signel--pending-input) "halfwritten")))) - -(ert-deftest test-signel-input-msg-preserves-pending-input () - "Regression for #2: `signel--insert-msg' (the receive path) redraws the -prompt without clobbering the user's in-progress input." - (test-signel--with-chat-buffer - (insert "halfwritten") - (cl-letf (((symbol-function 'signel--get-buffer) - (lambda (_) (current-buffer)))) - (signel--insert-msg "+15555550100" "Alice" "Hi there" nil nil nil)) - (should (string-match-p "Hi there" (buffer-string))) - (should (equal (signel--pending-input) "halfwritten")))) - -(provide 'test-signel-input-preservation) -;;; test-signel-input-preservation.el ends here diff --git a/tests/test-signel-notify-function.el b/tests/test-signel-notify-function.el deleted file mode 100644 index e3d97af5..00000000 --- a/tests/test-signel-notify-function.el +++ /dev/null @@ -1,89 +0,0 @@ -;;; test-signel-notify-function.el --- Tests for signel's notify-function dispatch -*- lexical-binding: t -*- - -;;; Commentary: -;; signel's receive handler (signel.el in the fork at ~/code/signel) -;; raised notifications through a hardwired `notifications-notify' -;; call. The notification slice (docs/specs/signal-client-spec-doing.org, -;; "Notification slice" addendum) replaces that with -;; `signel-notify-function', a customization point called with -;; CHAT-ID, SENDER, and BODY so a config layer can add suppression or -;; route through an external notifier. These tests cover the -;; dispatch: text, sticker, and attachment bodies reach the function -;; with the right arguments, and the default preserves the plain -;; `notifications-notify' behavior. -;; -;; `signel--handle-receive' is exercised directly with synthetic -;; envelope alists; buffer/dashboard side effects are stubbed. No -;; live process needed. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defun test-signel-notify--receive (envelope) - "Run `signel--handle-receive' on ENVELOPE, capturing notify calls. -Returns the list of (CHAT-ID SENDER BODY) argument lists the handler -passed to `signel-notify-function', oldest first. Buffer and -dashboard side effects are stubbed out." - (let (calls) - (cl-letf (((symbol-function 'signel--insert-msg) (lambda (&rest _) nil)) - ((symbol-function 'signel--dashboard-refresh) (lambda () nil)) - ((symbol-function 'signel--get-buffer) - (lambda (_) (current-buffer)))) - (let ((signel-notify-function - (lambda (chat-id sender body) - (push (list chat-id sender body) calls))) - (signel-auto-open-buffer nil)) - (signel--handle-receive `((envelope . ,envelope))))) - (nreverse calls))) - -(ert-deftest test-signel-notify-function-text-message () - "Normal: a text dataMessage calls the function with chat-id, sender, text." - (should (equal (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (dataMessage . ((message . "hi there"))))) - '(("+15551234567" "Alice" "hi there"))))) - -(ert-deftest test-signel-notify-function-sticker-placeholder () - "Boundary: a sticker with no text gets the [Sticker] placeholder body." - (should (equal (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (dataMessage . ((sticker . ((packId . "p1"))))))) - '(("+15551234567" "Alice" "[Sticker]"))))) - -(ert-deftest test-signel-notify-function-attachment-placeholder () - "Boundary: an attachment with no text gets the [Attachment] placeholder." - (should (equal (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (dataMessage . ((attachments . [((id . "a1"))]))))) - '(("+15551234567" "Alice" "[Attachment]"))))) - -(ert-deftest test-signel-notify-function-no-data-no-call () - "Boundary: an envelope with no dataMessage never calls the function." - (should-not (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (typingMessage . ((action . "STARTED"))))))) - -(ert-deftest test-signel-notify-function-default-preserves-behavior () - "Normal: the default value raises a plain notifications-notify toast." - (should (eq signel-notify-function #'signel--notify-default)) - (let (calls) - (cl-letf (((symbol-function 'notifications-notify) - (lambda (&rest args) (push args calls) nil))) - (signel--notify-default "+15551234567" "Alice" "hi")) - (should (= (length calls) 1)) - (let ((args (car calls))) - (should (equal (plist-get args :title) "Signel: Alice")) - (should (equal (plist-get args :body) "hi"))))) - -(provide 'test-signel-notify-function) -;;; test-signel-notify-function.el ends here diff --git a/tests/test-signel-rpc-dispatch.el b/tests/test-signel-rpc-dispatch.el deleted file mode 100644 index 5ae023d6..00000000 --- a/tests/test-signel-rpc-dispatch.el +++ /dev/null @@ -1,94 +0,0 @@ -;;; test-signel-rpc-dispatch.el --- Tests for signel JSON-RPC success-result dispatch -*- lexical-binding: t; -*- - -;;; Commentary: -;; signel's JSON-RPC dispatch (signel.el in the fork at ~/code/signel) routes -;; incoming `receive' notifications and errors, but successful -;; `((id . N) (result . VALUE))' responses had no path until this work added a -;; request-callback table. These tests cover the new behavior: a registered -;; callback fires with the result and is then removed; an error response -;; also removes the handler so a retry starts clean; an unregistered id is a -;; silent no-op; passing SUCCESS-CALLBACK to `signel--send-rpc' registers it -;; under the returned id. -;; -;; The dispatch tests exercise `signel--dispatch' directly with synthetic JSON -;; alists; no live process is needed. The send-rpc test stubs `get-process' -;; and `process-send-string' so it doesn't require a running signal-cli. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defun test-signel-rpc--reset () - "Reset signel dispatch state to a clean baseline before each test." - (clrhash signel--request-handler-map) - (clrhash signel--request-buffer-map) - (setq signel--rpc-id-counter 0)) - -(ert-deftest test-signel-rpc-dispatch-result-invokes-callback () - "Normal: a result response with a registered id fires the callback with the -result value and removes the handler." - (test-signel-rpc--reset) - (let ((captured nil)) - (puthash 7 (lambda (val) (setq captured val)) signel--request-handler-map) - (signel--dispatch '((jsonrpc . "2.0") (id . 7) - (result . ((contacts . [1 2 3]))))) - (should (equal captured '((contacts . [1 2 3])))) - (should-not (gethash 7 signel--request-handler-map)))) - -(ert-deftest test-signel-rpc-dispatch-unknown-id-is-noop () - "Boundary: a result response with an unregistered id is a silent no-op: -neither receive nor error handler fires, and the handler map stays empty." - (test-signel-rpc--reset) - (let ((called nil)) - (cl-letf (((symbol-function 'signel--handle-error) - (lambda (&rest _) (setq called 'error))) - ((symbol-function 'signel--handle-receive) - (lambda (&rest _) (setq called 'receive)))) - (signel--dispatch '((jsonrpc . "2.0") (id . 99) (result . "anything")))) - (should-not called) - (should (zerop (hash-table-count signel--request-handler-map))))) - -(ert-deftest test-signel-rpc-dispatch-error-cleans-up-handler () - "Error: an error response with a registered id removes the handler without -firing the callback, leaving the map clean for a retry." - (test-signel-rpc--reset) - (let ((fired nil)) - (puthash 11 (lambda (&rest _) (setq fired t)) - signel--request-handler-map) - (cl-letf (((symbol-function 'signel--handle-error) (lambda (&rest _) nil))) - (signel--dispatch '((jsonrpc . "2.0") (id . 11) - (error . ((code . -1) (message . "boom")))))) - (should-not fired) - (should-not (gethash 11 signel--request-handler-map)))) - -(ert-deftest test-signel-rpc-send-rpc-registers-success-callback () - "Normal: passing a SUCCESS-CALLBACK to `signel--send-rpc' stores it under -the returned id so the matching response can route to it." - (test-signel-rpc--reset) - (let ((cb (lambda (_) 'ok)) - (sent nil)) - (cl-letf (((symbol-function 'get-process) (lambda (&rest _) 'fake-proc)) - ((symbol-function 'process-send-string) - (lambda (_ s) (setq sent s))) - ((symbol-function 'signel--log) (lambda (&rest _) nil))) - (let ((id (signel--send-rpc "listContacts" nil nil cb))) - (should (eq cb (gethash id signel--request-handler-map))) - (should (stringp sent)))))) - -(ert-deftest test-signel-rpc-stop-clears-handler-map () - "Normal (reconnect-invalidation): `signel-stop' clears the handler map so a -restart starts with no stale callbacks waiting for responses that will never -arrive." - (test-signel-rpc--reset) - (puthash 13 (lambda (&rest _) nil) signel--request-handler-map) - (cl-letf (((symbol-function 'get-process) (lambda (&rest _) nil))) - (signel-stop)) - (should (zerop (hash-table-count signel--request-handler-map)))) - -(provide 'test-signel-rpc-dispatch) -;;; test-signel-rpc-dispatch.el ends here diff --git a/tests/test-slack-config--notify.el b/tests/test-slack-config--notify.el new file mode 100644 index 00000000..d830ae29 --- /dev/null +++ b/tests/test-slack-config--notify.el @@ -0,0 +1,113 @@ +;;; test-slack-config--notify.el --- Slack notification hardening tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found `cj/slack-notify' missing signel's hardening: no +;; body truncation (giant toasts), no whitespace collapse, no sound gating, +;; and no `notifications-notify' fallback when the notify script is absent +;; (the raw `start-process' error was swallowed by the condition-case, so +;; the notification silently vanished). This mirrors signel's shape in +;; place; the shared cj/messenger-notify extraction belongs to the +;; messenger-unification task. +;; +;; The slack package's own predicates (`slack-im-p', `slack-message-minep', +;; `slack-message-mentioned-p') are package boundaries and are mocked; the +;; formatter and routing logic run real. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'slack-config) + +;;; ------------------------------ body formatter ----------------------------- + +(ert-deftest test-slack-config-format-notify-body-collapses-whitespace () + "Normal: whitespace runs (including newlines) become single spaces." + (should (equal (cj/slack--format-notify-body "a b\nc\t\td") + "a b c d"))) + +(ert-deftest test-slack-config-format-notify-body-truncates-long () + "Boundary: text over the max truncates to max length ending in an ellipsis." + (let ((long (make-string 500 ?x))) + (let ((formatted (cj/slack--format-notify-body long))) + (should (= (length formatted) cj/slack--notify-body-max)) + (should (string-suffix-p "…" formatted))))) + +(ert-deftest test-slack-config-format-notify-body-empty () + "Boundary: empty and whitespace-only input format to the empty string." + (should (equal (cj/slack--format-notify-body "") "")) + (should (equal (cj/slack--format-notify-body " \n\t ") ""))) + +;;; ----------------------------- delivery routing ---------------------------- + +(ert-deftest test-slack-config-send-notification-script-silent-by-default () + "Normal: with the notify script on PATH and sound off, --silent is passed." + (let ((argv nil) (cj/slack-notify-sound nil)) + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "notify") "/bin/notify"))) + ((symbol-function 'start-process) + (lambda (_name _buf &rest args) (setq argv args)))) + (cj/slack--send-notification "Slack: general" "hello")) + (should (equal argv '("/bin/notify" "info" "Slack: general" "hello" "--silent"))))) + +(ert-deftest test-slack-config-send-notification-sound-enabled () + "Boundary: with sound enabled, --silent is not passed." + (let ((argv nil) (cj/slack-notify-sound t)) + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "notify") "/bin/notify"))) + ((symbol-function 'start-process) + (lambda (_name _buf &rest args) (setq argv args)))) + (cj/slack--send-notification "Slack: general" "hello")) + (should (equal argv '("/bin/notify" "info" "Slack: general" "hello"))))) + +(ert-deftest test-slack-config-send-notification-fallback-without-script () + "Error: with no notify script, delivery falls back to notifications-notify." + (let ((fallback nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'notifications-notify) + (lambda (&rest args) (setq fallback args)))) + (cj/slack--send-notification "Slack: general" "hello")) + (should (equal (plist-get fallback :title) "Slack: general")) + (should (equal (plist-get fallback :body) "hello")))) + +;;; --------------------------- predicate wiring ------------------------------ + +(defmacro test-slack-notify--with-message (minep im-p mentioned-p &rest body) + "Run BODY with the slack package predicates mocked to the given values. +Also mocks room/body accessors and captures delivery into `sent'." + (declare (indent 3)) + `(let ((sent nil)) + (cl-letf (((symbol-function 'slack-message-minep) (lambda (&rest _) ,minep)) + ((symbol-function 'slack-im-p) (lambda (&rest _) ,im-p)) + ((symbol-function 'slack-message-mentioned-p) (lambda (&rest _) ,mentioned-p)) + ((symbol-function 'slack-room-display-name) (lambda (&rest _) "general")) + ((symbol-function 'slack-message-body) (lambda (&rest _) "the message")) + ((symbol-function 'cj/slack--send-notification) + (lambda (title body) (setq sent (list title body))))) + (cj/slack-notify 'msg 'room 'team) + ,@body))) + +(ert-deftest test-slack-config-notify-dm-notifies () + "Normal: a DM from someone else raises a notification." + (test-slack-notify--with-message nil t nil + (should (equal sent '("Slack: general" "the message"))))) + +(ert-deftest test-slack-config-notify-mention-notifies () + "Normal: an @mention in a channel raises a notification." + (test-slack-notify--with-message nil nil t + (should (equal sent '("Slack: general" "the message"))))) + +(ert-deftest test-slack-config-notify-own-message-silent () + "Boundary: your own message never notifies, even in a DM." + (test-slack-notify--with-message t t t + (should-not sent))) + +(ert-deftest test-slack-config-notify-plain-channel-silent () + "Boundary: a channel message with no mention stays silent." + (test-slack-notify--with-message nil nil nil + (should-not sent))) + +(provide 'test-slack-config--notify) +;;; test-slack-config--notify.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-test-runner.el b/tests/test-test-runner.el index 0ff66f7f..6854b72e 100644 --- a/tests/test-test-runner.el +++ b/tests/test-test-runner.el @@ -152,6 +152,25 @@ FILES is an alist of relative test filenames to file contents." (should (eq (car result) 'not-in-testdir))) (test-testrunner-teardown)) +(ert-deftest test-testrunner-focus-add-file-shared-prefix-sibling-rejected () + "Boundary: a sibling directory sharing the test dir's name prefix is outside it. +`/tmp/x/tests-old/f.el' starts with `/tmp/x/tests' as a string, but it is not +in `/tmp/x/tests'. A raw `string-prefix-p' on the two truenames accepts it; +comparing against the directory with a trailing slash rejects it." + (test-testrunner-setup) + (let* ((testdir (file-truename test-testrunner--temp-dir)) + (sibling (concat (directory-file-name testdir) "-old")) + (filepath (expand-file-name "test-foo.el" sibling))) + (unwind-protect + (progn + (make-directory sibling t) + (with-temp-file filepath (insert ";; not in the test dir\n")) + (let ((result (cj/test--do-focus-add-file + filepath test-testrunner--temp-dir '()))) + (should (eq (car result) 'not-in-testdir)))) + (when (file-directory-p sibling) (delete-directory sibling t)))) + (test-testrunner-teardown)) + (ert-deftest test-testrunner-focus-add-file-already-focused () "Should detect already focused file." (test-testrunner-setup) diff --git a/tests/test-text-config.el b/tests/test-text-config.el index 96935e1b..82dfe05e 100644 --- a/tests/test-text-config.el +++ b/tests/test-text-config.el @@ -37,5 +37,18 @@ standard boundary check." (should (eq (cj/prettify-compose-block-markers-p start end "lambda") (prettify-symbols-default-compose-p start end "lambda")))))) +(ert-deftest test-text-config-edit-indirect-bound-on-reachable-key () + "Error/regression: edit-indirect-region is bound on M-I -- the event +Meta+Shift+i actually produces -- not the unreachable M-S-i, which no +keypress generates so it silently fell through to M-i tab-to-tab-stop." + (should (eq (key-binding (kbd "M-I")) #'edit-indirect-region)) + (should-not (eq (key-binding (kbd "M-S-i")) #'edit-indirect-region))) + +(ert-deftest test-text-config-accent-uses-completion-agnostic-backend () + "Regression: C-` invokes accent-menu, which reads through the minibuffer +and so survives a Company->Corfu migration, rather than accent-company, +whose company backend would break silently once Company is gone." + (should (eq (key-binding (kbd "C-`")) #'accent-menu))) + (provide 'test-text-config) ;;; test-text-config.el ends here diff --git a/tests/test-ui-theme-persistence.el b/tests/test-ui-theme-persistence.el index 02bb105a..250b606b 100644 --- a/tests/test-ui-theme-persistence.el +++ b/tests/test-ui-theme-persistence.el @@ -32,6 +32,19 @@ "modus-vivendi"))) (delete-file file)))) +(ert-deftest test-ui-theme-write-file-contents-creates-missing-parent-dir () + "Boundary: writing into a not-yet-existing directory creates it first. +On a fresh machine `persist/' does not exist, and `file-writable-p' returns nil +for a file inside a missing directory, so the write must create the parent." + (let* ((sandbox (make-temp-file "ui-theme-sandbox-" t)) + (file (expand-file-name "persist/emacs-theme" sandbox))) + (unwind-protect + (progn + (should-not (file-directory-p (file-name-directory file))) + (should (cj/theme-write-file-contents "modus-vivendi" file)) + (should (equal (cj/theme-read-file-contents file) "modus-vivendi"))) + (delete-directory sandbox t)))) + (ert-deftest test-ui-theme-write-file-contents-uses-write-region () "Theme persistence should write directly instead of visiting the file." (let ((file (make-temp-file "ui-theme-write-region-")) diff --git a/tests/test-undead-buffers-kill-other-window.el b/tests/test-undead-buffers-kill-other-window.el index e9371a0f..000ada9b 100644 --- a/tests/test-undead-buffers-kill-other-window.el +++ b/tests/test-undead-buffers-kill-other-window.el @@ -66,8 +66,9 @@ ;;; Boundary Cases -(ert-deftest test-kill-other-window-single-window-should-only-kill-buffer () - "With single window, should only kill the current buffer." +(ert-deftest test-kill-other-window-single-window-signals-no-other-window () + "Error: with a single window, signal `user-error' and kill nothing. +There is no other window, so acting would kill the buffer being viewed." (test-kill-other-window-setup) (unwind-protect (let ((buf (generate-new-buffer "*test-single-other*"))) @@ -75,9 +76,9 @@ (progn (switch-to-buffer buf) (should (one-window-p)) - (cj/kill-other-window) + (should-error (cj/kill-other-window) :type 'user-error) (should (one-window-p)) - (should-not (buffer-live-p buf))) + (should (buffer-live-p buf))) (when (buffer-live-p buf) (kill-buffer buf)))) (test-kill-other-window-teardown))) 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--build-video-command.el b/tests/test-video-audio-recording--build-video-command.el index 4f290978..1ffce95b 100644 --- a/tests/test-video-audio-recording--build-video-command.el +++ b/tests/test-video-audio-recording--build-video-command.el @@ -27,6 +27,14 @@ (should (string-match-p "-i pipe:0" cmd)) (should (string-match-p "-c:v copy" cmd)))))) +(ert-deftest test-video-audio-recording--build-video-command-normal-wayland-keeps-wf-recorder-stderr () + "Wayland command does not discard wf-recorder stderr, so a failed grab is diagnosable." + (let ((cj/recording-mic-boost 2.0) + (cj/recording-system-volume 1.0)) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) + (let ((cmd (cj/recording--build-video-command "mic" "sys" "/tmp/out.mkv" t))) + (should-not (string-match-p "2>/dev/null" cmd)))))) + (ert-deftest test-video-audio-recording--build-video-command-normal-x11-uses-x11grab () "X11 command uses ffmpeg with x11grab, no wf-recorder." (let ((cj/recording-mic-boost 2.0) diff --git a/tests/test-video-audio-recording--start-race.el b/tests/test-video-audio-recording--start-race.el new file mode 100644 index 00000000..36ea8595 --- /dev/null +++ b/tests/test-video-audio-recording--start-race.el @@ -0,0 +1,56 @@ +;;; test-video-audio-recording--start-race.el --- start-race fix tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the wf-recorder start-race fix: the poll that waits for a dying +;; wf-recorder to release the compositor capture before launching a new one, and +;; the fail-fast timing predicate that tells a 0.5s failed start from a real +;; recording. The pgrep wrapper and the live start/stop wiring are exercised in +;; the daemon, not here; the poll is tested with an injected predicate so no real +;; process is needed. + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'video-audio-recording) + +(declare-function cj/recording--start-failed-p "video-audio-recording-capture" (elapsed threshold)) +(declare-function cj/recording--wait-for-no-wf-recorder "video-audio-recording-capture" (timeout-secs &optional running-p)) + +;;; ------------------------- cj/recording--start-failed-p --------------------- + +(ert-deftest test-recording-start-failed-p-short-exit-is-failure () + "Normal: an exit well before the threshold is a failed start." + (should (cj/recording--start-failed-p 0.5 1.5))) + +(ert-deftest test-recording-start-failed-p-long-run-is-not-failure () + "Normal: a long-running recording that ends is not a failed start." + (should-not (cj/recording--start-failed-p 30.0 1.5))) + +(ert-deftest test-recording-start-failed-p-at-threshold-is-not-failure () + "Boundary: an exit exactly at the threshold is not counted as failed." + (should-not (cj/recording--start-failed-p 1.5 1.5))) + +;;; -------------------- cj/recording--wait-for-no-wf-recorder ------------------ + +(ert-deftest test-recording-wait-for-no-wf-recorder-clears () + "Normal: returns t once the injected predicate reports wf-recorder gone." + (let ((n 0)) + (should (cj/recording--wait-for-no-wf-recorder + 2.0 + (lambda () (setq n (1+ n)) (< n 3)))))) + +(ert-deftest test-recording-wait-for-no-wf-recorder-already-clear () + "Boundary: an already-clear predicate returns t immediately." + (should (cj/recording--wait-for-no-wf-recorder 2.0 (lambda () nil)))) + +(ert-deftest test-recording-wait-for-no-wf-recorder-times-out () + "Error: a predicate that never clears returns nil at the timeout." + (should-not (cj/recording--wait-for-no-wf-recorder 0.15 (lambda () t)))) + +(provide 'test-video-audio-recording--start-race) +;;; test-video-audio-recording--start-race.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 |