diff options
Diffstat (limited to 'tests')
206 files changed, 6149 insertions, 6921 deletions
diff --git a/tests/run-coverage-file.el b/tests/run-coverage-file.el index 6ac65300b..0cbfed4f5 100644 --- a/tests/run-coverage-file.el +++ b/tests/run-coverage-file.el @@ -9,7 +9,7 @@ ;; Per-file isolation matches the project's `make test-unit' pattern: ;; each test file runs in its own Emacs process, so tests that work ;; under `make test' will also work under `make coverage'. See -;; docs/design/coverage.org for the rationale. +;; docs/specs/coverage-spec-implemented.org for the rationale. ;;; Code: @@ -32,7 +32,6 @@ (setq undercover-force-coverage t) (undercover "modules/*.el" - "gptel-tools/*.el" (:report-format 'simplecov) (:report-file ".coverage/simplecov.json") (:merge-report t) diff --git a/tests/test-ai-config-auth-source-secret.el b/tests/test-ai-config-auth-source-secret.el deleted file mode 100644 index bab506e5f..000000000 --- a/tests/test-ai-config-auth-source-secret.el +++ /dev/null @@ -1,27 +0,0 @@ -;;; test-ai-config-auth-source-secret.el --- Tests for the required-secret wrapper -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/auth-source-secret' is the required-secret layer over the shared -;; `cj/auth-source-secret-value' primitive: it returns the secret, or errors -;; when none is found. These tests stub the primitive to exercise both paths. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ai-config) - -(ert-deftest test-ai-config-auth-source-secret-returns-value () - "Normal: returns the value the primitive resolves." - (cl-letf (((symbol-function 'cj/auth-source-secret-value) (lambda (&rest _) "sk-x"))) - (should (equal "sk-x" (cj/auth-source-secret "api.example.com" "apikey"))))) - -(ert-deftest test-ai-config-auth-source-secret-errors-on-miss () - "Error: signals when the primitive finds no secret." - (cl-letf (((symbol-function 'cj/auth-source-secret-value) (lambda (&rest _) nil))) - (should-error (cj/auth-source-secret "api.example.com" "apikey")))) - -(provide 'test-ai-config-auth-source-secret) -;;; test-ai-config-auth-source-secret.el ends here diff --git a/tests/test-ai-config-backend-and-model.el b/tests/test-ai-config-backend-and-model.el deleted file mode 100644 index c03c58a2d..000000000 --- a/tests/test-ai-config-backend-and-model.el +++ /dev/null @@ -1,78 +0,0 @@ -;;; test-ai-config-backend-and-model.el --- Tests for cj/gptel-backend-and-model -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for cj/gptel-backend-and-model from ai-config.el. -;; -;; Returns a formatted string "backend: model [timestamp]" for use in -;; org headings marking AI responses. Uses pcase to extract the display -;; name from vector backends, falling back to "AI" otherwise. - -;;; Code: - -(require 'ert) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'testutil-ai-config) -(require 'ai-config) - -;;; Normal Cases - -(ert-deftest test-ai-config-backend-and-model-normal-vector-backend-extracts-name () - "Vector backend should use element at index 1 as display name." - (let ((gptel-backend (vector 'cl-struct "Claude")) - (gptel-model "claude-opus-4-6")) - (let ((result (cj/gptel-backend-and-model))) - (should (string-match-p "^Claude:" result)) - (should (string-match-p "claude-opus-4-6" result))))) - -(ert-deftest test-ai-config-backend-and-model-normal-contains-timestamp () - "Result should contain a bracketed timestamp." - (let ((gptel-backend nil) - (gptel-model nil)) - (should (string-match-p "\\[[-0-9]+ [0-9]+:[0-9]+:[0-9]+\\]" - (cj/gptel-backend-and-model))))) - -(ert-deftest test-ai-config-backend-and-model-normal-format-structure () - "Result should follow 'backend: model [timestamp]' format." - (let ((gptel-backend (vector 'cl-struct "TestBackend")) - (gptel-model "test-model")) - (should (string-match-p "^TestBackend: test-model \\[" - (cj/gptel-backend-and-model))))) - -;;; Boundary Cases - -(ert-deftest test-ai-config-backend-and-model-boundary-nil-backend-shows-ai () - "Nil backend should fall back to \"AI\" display name." - (let ((gptel-backend nil) - (gptel-model "some-model")) - (should (string-match-p "^AI:" (cj/gptel-backend-and-model))))) - -(ert-deftest test-ai-config-backend-and-model-boundary-nil-model-shows-empty () - "Nil model should produce empty string in model position." - (let ((gptel-backend nil) - (gptel-model nil)) - (should (string-match-p "^AI: \\[" (cj/gptel-backend-and-model))))) - -(ert-deftest test-ai-config-backend-and-model-boundary-string-backend-shows-ai () - "String backend (not vector) should fall back to \"AI\"." - (let ((gptel-backend "just-a-string") - (gptel-model "model")) - (should (string-match-p "^AI:" (cj/gptel-backend-and-model))))) - -(ert-deftest test-ai-config-backend-and-model-boundary-symbol-model-formatted () - "Symbol model should be formatted as its print representation." - (let ((gptel-backend nil) - (gptel-model 'some-model)) - (should (string-match-p "some-model" (cj/gptel-backend-and-model))))) - -(ert-deftest test-ai-config-backend-and-model-boundary-timestamp-reflects-today () - "Timestamp should contain today's date." - (let ((gptel-backend nil) - (gptel-model nil) - (today (format-time-string "%Y-%m-%d"))) - (should (string-match-p (regexp-quote today) - (cj/gptel-backend-and-model))))) - -(provide 'test-ai-config-backend-and-model) -;;; test-ai-config-backend-and-model.el ends here diff --git a/tests/test-ai-config-build-model-list.el b/tests/test-ai-config-build-model-list.el deleted file mode 100644 index 827036038..000000000 --- a/tests/test-ai-config-build-model-list.el +++ /dev/null @@ -1,101 +0,0 @@ -;;; test-ai-config-build-model-list.el --- Tests for cj/gptel--build-model-list -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for cj/gptel--build-model-list from ai-config.el. -;; -;; Pure function that takes a backends alist and a model-fetching function, -;; and produces a flat list of (DISPLAY-STRING BACKEND MODEL-STRING BACKEND-NAME) -;; entries suitable for completing-read. Exercises the mapping and string -;; formatting logic that was previously embedded in cj/gptel-change-model. - -;;; Code: - -(require 'ert) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'testutil-ai-config) -(require 'ai-config) - -;;; Normal Cases - -(ert-deftest test-ai-config-build-model-list-normal-single-backend-single-model () - "One backend with one model should produce one entry." - (let* ((backend-obj 'fake-backend) - (backends `(("Claude" . ,backend-obj))) - (result (cj/gptel--build-model-list backends (lambda (_) '("opus"))))) - (should (= 1 (length result))) - (should (equal (car (nth 0 result)) "Claude: opus")) - (should (eq (nth 1 (nth 0 result)) backend-obj)) - (should (equal (nth 2 (nth 0 result)) "opus")) - (should (equal (nth 3 (nth 0 result)) "Claude")))) - -(ert-deftest test-ai-config-build-model-list-normal-single-backend-multiple-models () - "One backend with multiple models should produce one entry per model." - (let* ((backends '(("Claude" . backend-a))) - (result (cj/gptel--build-model-list - backends (lambda (_) '("opus" "sonnet" "haiku"))))) - (should (= 3 (length result))) - (should (equal (mapcar #'car result) - '("Claude: opus" "Claude: sonnet" "Claude: haiku"))))) - -(ert-deftest test-ai-config-build-model-list-normal-multiple-backends () - "Multiple backends should interleave their models in backend order." - (let* ((backends '(("Claude" . backend-a) ("OpenAI" . backend-b))) - (result (cj/gptel--build-model-list - backends - (lambda (b) - (if (eq b 'backend-a) '("opus") '("gpt-4o")))))) - (should (= 2 (length result))) - (should (equal (car (nth 0 result)) "Claude: opus")) - (should (equal (car (nth 1 result)) "OpenAI: gpt-4o")))) - -(ert-deftest test-ai-config-build-model-list-normal-preserves-backend-object () - "Each entry should carry the original backend object for later use." - (let* ((obj (vector 'struct "Claude")) - (backends `(("Claude" . ,obj))) - (result (cj/gptel--build-model-list backends (lambda (_) '("opus"))))) - (should (eq (nth 1 (nth 0 result)) obj)))) - -(ert-deftest test-ai-config-build-model-list-normal-symbol-models-converted () - "Symbol model identifiers should be converted to strings via model-to-string." - (let* ((backends '(("Claude" . backend-a))) - (result (cj/gptel--build-model-list - backends (lambda (_) '(opus sonnet))))) - (should (equal (nth 2 (nth 0 result)) "opus")) - (should (equal (nth 2 (nth 1 result)) "sonnet")))) - -;;; Boundary Cases - -(ert-deftest test-ai-config-build-model-list-boundary-empty-backends () - "Empty backends list should produce empty result." - (should (null (cj/gptel--build-model-list nil (lambda (_) '("x")))))) - -(ert-deftest test-ai-config-build-model-list-boundary-backend-with-no-models () - "Backend returning no models should contribute no entries." - (let* ((backends '(("Claude" . backend-a))) - (result (cj/gptel--build-model-list backends (lambda (_) nil)))) - (should (null result)))) - -(ert-deftest test-ai-config-build-model-list-boundary-mixed-empty-and-populated () - "Only backends with models should produce entries." - (let* ((backends '(("Claude" . backend-a) ("Empty" . backend-b) ("OpenAI" . backend-c))) - (result (cj/gptel--build-model-list - backends - (lambda (b) - (cond ((eq b 'backend-a) '("opus")) - ((eq b 'backend-b) nil) - ((eq b 'backend-c) '("gpt-4o"))))))) - (should (= 2 (length result))) - (should (equal (nth 3 (nth 0 result)) "Claude")) - (should (equal (nth 3 (nth 1 result)) "OpenAI")))) - -(ert-deftest test-ai-config-build-model-list-boundary-model-with-special-characters () - "Model names with special characters should be preserved in display string." - (let* ((backends '(("Claude" . backend-a))) - (result (cj/gptel--build-model-list - backends (lambda (_) '("claude-haiku-4-5-20251001"))))) - (should (equal (car (nth 0 result)) "Claude: claude-haiku-4-5-20251001")))) - -(provide 'test-ai-config-build-model-list) -;;; test-ai-config-build-model-list.el ends here diff --git a/tests/test-ai-config-commands.el b/tests/test-ai-config-commands.el deleted file mode 100644 index 8da2e4b01..000000000 --- a/tests/test-ai-config-commands.el +++ /dev/null @@ -1,160 +0,0 @@ -;;; test-ai-config-commands.el --- Tests for ai-config interactive commands -*- lexical-binding: t; -*- - -;;; Commentary: -;; Sibling tests cover the pure helpers (model-to-string, build-model-list, -;; current-model-selection, fresh-org-prefix, backend-and-model). This -;; file covers the user-facing wrappers: -;; -;; cj/gptel--available-backends -;; cj/gptel-change-model -;; cj/gptel-add-file -;; cj/gptel-add-this-buffer -;; cj/toggle-gptel -;; cj/gptel-context-clear - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ai-config) - -;; Top-level defvars so let-bindings reach the dynamic binding under -;; lexical scope. -(defvar gptel-backend nil) -(defvar gptel-model nil) -(defvar gptel-claude-backend nil) -(defvar gptel-chatgpt-backend nil) -(defvar gptel-context--alist nil) - -;;; cj/gptel--available-backends - -(ert-deftest test-ai-available-backends-returns-claude-and-chatgpt () - "Normal: both backends present become alist entries." - (let ((gptel-claude-backend 'claude-obj) - (gptel-chatgpt-backend 'chatgpt-obj)) - (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'cj/ensure-gptel-backends) #'ignore)) - (let ((result (cj/gptel--available-backends))) - (should (equal (assoc "Anthropic - Claude" result) - '("Anthropic - Claude" . claude-obj))) - (should (equal (assoc "OpenAI - ChatGPT" result) - '("OpenAI - ChatGPT" . chatgpt-obj))))))) - -(ert-deftest test-ai-available-backends-skips-nil-entries () - "Boundary: only configured backends appear in the alist." - (let ((gptel-claude-backend nil) - (gptel-chatgpt-backend 'chatgpt-only)) - (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'cj/ensure-gptel-backends) #'ignore)) - (let ((result (cj/gptel--available-backends))) - (should-not (assoc "Anthropic - Claude" result)) - (should (assoc "OpenAI - ChatGPT" result)))))) - -;;; cj/gptel-change-model - -(ert-deftest test-ai-change-model-global-sets-globals-and-messages () - "Normal: choosing 'global' sets `gptel-backend' and `gptel-model' -globally and reports via `message'." - (let ((gptel-backend 'old-backend) - (gptel-model 'old-model) - (gptel-claude-backend 'claude-obj) - (gptel-chatgpt-backend nil) - msg) - (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'cj/ensure-gptel-backends) #'ignore) - ((symbol-function 'gptel-backend-models) - (lambda (_) '("claude-opus-4-7"))) - ((symbol-function 'completing-read) - (lambda (prompt &rest _) - (if (string-prefix-p "Set model for" prompt) - "global" - "Anthropic - Claude: claude-opus-4-7"))) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/gptel-change-model)) - (should (eq gptel-backend 'claude-obj)) - (should (eq gptel-model 'claude-opus-4-7)) - (should (string-match-p "global" msg)))) - -;;; cj/gptel-add-file - -(ert-deftest test-ai-add-file-outside-projectile-uses-read-file-name () - "Normal: without projectile, add-file routes through read-file-name." - (let* ((target (make-temp-file "cj-ai-add-file-" nil ".org")) - added) - (unwind-protect - (cl-letf (((symbol-function 'featurep) - (lambda (sym) (not (eq sym 'projectile)))) - ((symbol-function 'read-file-name) - (lambda (&rest _) target)) - ((symbol-function 'gptel-add-file) - (lambda (f) (setq added f))) - ((symbol-function 'message) #'ignore)) - (cj/gptel-add-file)) - (delete-file target)) - (should (equal added target)))) - -;;; cj/gptel-add-this-buffer - -(ert-deftest test-ai-add-this-buffer-calls-gptel-add-with-prefix () - "Normal: add-this-buffer calls `gptel-add' with the prefix-arg form." - (let (gptel-add-args msg) - (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'gptel-add) - (lambda (&rest args) (setq gptel-add-args args))) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/gptel-add-this-buffer)) - (should (equal gptel-add-args '((4)))) - (should (string-match-p "to GPTel context" msg)))) - -;;; cj/toggle-gptel - -(ert-deftest test-ai-toggle-gptel-hides-when-visible () - "Normal: when the AI buffer is showing in a window, toggle hides it." - (let ((buffer (get-buffer-create "*AI-Assistant*")) - deleted-window) - (unwind-protect - (cl-letf (((symbol-function 'get-buffer-window) - (lambda (&rest _) 'fake-window)) - ((symbol-function 'delete-window) - (lambda (w) (setq deleted-window w)))) - (cj/toggle-gptel)) - (kill-buffer buffer)) - (should (eq deleted-window 'fake-window)))) - -;;; cj/gptel-context-clear - -(ert-deftest test-ai-context-clear-uses-remove-all-when-available () - "Normal: with `gptel-context-remove-all' present, it is called." - (let (called msg) - (cl-letf (((symbol-function 'gptel-context-remove-all) - (lambda () (setq called t))) - ((symbol-function 'call-interactively) - (lambda (fn) (funcall fn))) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/gptel-context-clear)) - (should called) - (should (string-match-p "cleared" msg)))) - -(ert-deftest test-ai-context-clear-resets-alist-as-fallback () - "Boundary: when no clear function exists but the alist does, it gets -nilled directly." - (let ((gptel-context--alist '("item1" "item2")) - msg) - ;; Make sure the fboundp branches are skipped. - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) - (not (memq sym '(gptel-context-remove-all - gptel-context-clear))))) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/gptel-context-clear)) - (should-not gptel-context--alist) - (should (string-match-p "cleared" msg)))) - -(provide 'test-ai-config-commands) -;;; test-ai-config-commands.el ends here diff --git a/tests/test-ai-config-current-model-selection.el b/tests/test-ai-config-current-model-selection.el deleted file mode 100644 index 14f9391c8..000000000 --- a/tests/test-ai-config-current-model-selection.el +++ /dev/null @@ -1,74 +0,0 @@ -;;; test-ai-config-current-model-selection.el --- Tests for cj/gptel--current-model-selection -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for cj/gptel--current-model-selection from ai-config.el. -;; -;; Pure function that formats the active backend and model into a display -;; string like "Anthropic - Claude: claude-opus-4-6". Used as the default -;; selection in the model-switching completing-read prompt. - -;;; Code: - -(require 'ert) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'testutil-ai-config) -(require 'ai-config) - -;;; Normal Cases - -(ert-deftest test-ai-config-current-model-selection-normal-matching-backend () - "When current backend is in the backends alist, use its display name." - (let* ((backend-obj 'my-backend) - (backends `(("Anthropic - Claude" . ,backend-obj)))) - (should (equal (cj/gptel--current-model-selection backends backend-obj "opus") - "Anthropic - Claude: opus")))) - -(ert-deftest test-ai-config-current-model-selection-normal-symbol-model () - "Symbol model should be converted to string in the output." - (let* ((backend-obj 'my-backend) - (backends `(("Claude" . ,backend-obj)))) - (should (equal (cj/gptel--current-model-selection backends backend-obj 'opus) - "Claude: opus")))) - -(ert-deftest test-ai-config-current-model-selection-normal-multiple-backends () - "Should find the correct backend name among multiple backends." - (let* ((backend-a 'backend-a) - (backend-b 'backend-b) - (backends `(("Claude" . ,backend-a) ("OpenAI" . ,backend-b)))) - (should (equal (cj/gptel--current-model-selection backends backend-b "gpt-4o") - "OpenAI: gpt-4o")))) - -;;; Boundary Cases - -(ert-deftest test-ai-config-current-model-selection-boundary-nil-backend-shows-ai () - "Nil backend (not in alist) should fall back to \"AI\"." - (should (equal (cj/gptel--current-model-selection '(("Claude" . x)) nil "opus") - "AI: opus"))) - -(ert-deftest test-ai-config-current-model-selection-boundary-unknown-backend-shows-ai () - "Backend not found in alist should fall back to \"AI\"." - (should (equal (cj/gptel--current-model-selection - '(("Claude" . backend-a)) 'unknown-backend "opus") - "AI: opus"))) - -(ert-deftest test-ai-config-current-model-selection-boundary-nil-model () - "Nil model should produce \"nil\" in the model position (symbolp nil)." - (let* ((backend 'my-backend) - (backends `(("Claude" . ,backend)))) - (should (equal (cj/gptel--current-model-selection backends backend nil) - "Claude: nil")))) - -(ert-deftest test-ai-config-current-model-selection-boundary-empty-backends () - "Empty backends alist should fall back to \"AI\" for backend name." - (should (equal (cj/gptel--current-model-selection nil 'anything "model") - "AI: model"))) - -(ert-deftest test-ai-config-current-model-selection-boundary-both-nil () - "Nil backend and nil model should produce \"AI: nil\"." - (should (equal (cj/gptel--current-model-selection nil nil nil) - "AI: nil"))) - -(provide 'test-ai-config-current-model-selection) -;;; test-ai-config-current-model-selection.el ends here diff --git a/tests/test-ai-config-fresh-org-prefix.el b/tests/test-ai-config-fresh-org-prefix.el deleted file mode 100644 index 16a3211cf..000000000 --- a/tests/test-ai-config-fresh-org-prefix.el +++ /dev/null @@ -1,65 +0,0 @@ -;;; test-ai-config-fresh-org-prefix.el --- Tests for cj/gptel--fresh-org-prefix -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for cj/gptel--fresh-org-prefix from ai-config.el. -;; -;; Generates an org-mode level-1 heading containing the user's login -;; name and a bracketed timestamp, used as the user message prefix in -;; gptel org-mode conversations. - -;;; Code: - -(require 'ert) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'testutil-ai-config) -(require 'ai-config) - -;;; Normal Cases - -(ert-deftest test-ai-config-fresh-org-prefix-normal-starts-with-org-heading () - "Result should start with '* ' for an org level-1 heading." - (should (string-prefix-p "* " (cj/gptel--fresh-org-prefix)))) - -(ert-deftest test-ai-config-fresh-org-prefix-normal-contains-username () - "Result should contain the current user's login name." - (should (string-match-p (regexp-quote user-login-name) - (cj/gptel--fresh-org-prefix)))) - -(ert-deftest test-ai-config-fresh-org-prefix-normal-contains-timestamp () - "Result should contain a bracketed timestamp in YYYY-MM-DD HH:MM:SS format." - (should (string-match-p "\\[[-0-9]+ [0-9]+:[0-9]+:[0-9]+\\]" - (cj/gptel--fresh-org-prefix)))) - -(ert-deftest test-ai-config-fresh-org-prefix-normal-ends-with-newline () - "Result should end with a newline." - (should (string-suffix-p "\n" (cj/gptel--fresh-org-prefix)))) - -(ert-deftest test-ai-config-fresh-org-prefix-normal-format-order () - "Result should have star, then username, then timestamp in order." - (let ((result (cj/gptel--fresh-org-prefix))) - (should (string-match - (format "^\\* %s \\[" (regexp-quote user-login-name)) - result)))) - -;;; Boundary Cases - -(ert-deftest test-ai-config-fresh-org-prefix-boundary-timestamp-reflects-today () - "Timestamp should contain today's date." - (let ((today (format-time-string "%Y-%m-%d"))) - (should (string-match-p (regexp-quote today) - (cj/gptel--fresh-org-prefix))))) - -(ert-deftest test-ai-config-fresh-org-prefix-boundary-overridden-username () - "Result should reflect a dynamically-bound user-login-name." - (let ((user-login-name "testuser")) - (should (string-match-p "testuser" (cj/gptel--fresh-org-prefix))))) - -(ert-deftest test-ai-config-fresh-org-prefix-boundary-empty-username () - "Empty user-login-name should produce heading with empty name slot." - (let ((user-login-name "")) - (should (string-match-p "^\\* \\[" (cj/gptel--fresh-org-prefix))))) - -(provide 'test-ai-config-fresh-org-prefix) -;;; test-ai-config-fresh-org-prefix.el ends here diff --git a/tests/test-ai-config-gptel-backend-libs.el b/tests/test-ai-config-gptel-backend-libs.el deleted file mode 100644 index cbf48f444..000000000 --- a/tests/test-ai-config-gptel-backend-libs.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; test-ai-config-gptel-backend-libs.el --- Tests for gptel backend-lib loading -*- lexical-binding: t; -*- - -;;; Commentary: -;; Regression coverage for the "gptel-make-anthropic void" bug. The local -;; gptel fork (:load-path "~/code/gptel", :ensure nil) ships no generated -;; autoloads, so (require 'gptel) alone never loads gptel-anthropic / -;; gptel-openai where the gptel-make-* constructors live. The fix is to -;; require those backend libraries explicitly before constructing backends. -;; -;; These tests don't load gptel itself (it isn't reliably loadable in batch); -;; they stub `require' and the constructors to verify the loader requires both -;; libs and that `cj/ensure-gptel-backends' calls it before building backends. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ai-config) - -;; gptel defvars these at runtime; declare them here so the wiring test can -;; let-bind them in a batch session where gptel itself is not loaded. -(defvar gptel-backend) -(defvar gptel-model) - -(ert-deftest test-ai-config-gptel-load-backend-libs-requires-both () - "Normal: the loader requires gptel-anthropic and gptel-openai so the fork's -make-* constructors exist despite the missing autoloads." - (let ((required '())) - (cl-letf (((symbol-function 'require) - (lambda (feature &rest _) (push feature required) feature))) - (cj/--gptel-load-backend-libs)) - (should (memq 'gptel-anthropic required)) - (should (memq 'gptel-openai required)))) - -(ert-deftest test-ai-config-ensure-gptel-backends-loads-libs-first () - "Regression: `cj/ensure-gptel-backends' loads the backend libs before it -calls the constructors, so a fork without autoloads no longer signals -`void-function gptel-make-anthropic'." - (let ((loaded nil) - (gptel-claude-backend nil) - (gptel-chatgpt-backend nil) - (gptel-backend nil) - (gptel-model nil)) - (cl-letf (((symbol-function 'cj/--gptel-load-backend-libs) - (lambda () (setq loaded t))) - ((symbol-function 'gptel-make-anthropic) (lambda (&rest _) 'claude)) - ((symbol-function 'gptel-make-openai) (lambda (&rest _) 'chatgpt)) - ((symbol-function 'cj/anthropic-api-key) (lambda () "k")) - ((symbol-function 'cj/openai-api-key) (lambda () "k"))) - (cj/ensure-gptel-backends)) - (should loaded) - (should (eq gptel-claude-backend 'claude)) - (should (eq gptel-chatgpt-backend 'chatgpt)))) - -(provide 'test-ai-config-gptel-backend-libs) -;;; test-ai-config-gptel-backend-libs.el ends here diff --git a/tests/test-ai-config-gptel-commands.el b/tests/test-ai-config-gptel-commands.el deleted file mode 100644 index b87c4975e..000000000 --- a/tests/test-ai-config-gptel-commands.el +++ /dev/null @@ -1,152 +0,0 @@ -;;; test-ai-config-gptel-commands.el --- Tests for ai-config gptel command wrappers -*- lexical-binding: t; -*- - -;;; Commentary: -;; Second pass on ai-config. The first batch covered the helpers -;; (auth-source, api-key caching, add-file, clear-buffer, context- -;; clear, insert-model-heading). This file covers the gptel command -;; wrappers and a few small pure helpers: -;; -;; cj/gptel--refresh-org-prefix -;; cj/gptel-backend-and-model -;; cj/gptel-switch-backend -;; cj/gptel-add-buffer-file -;; cj/gptel-add-this-buffer -;; cj/toggle-gptel -;; -;; The gptel/projectile primitives are stubbed throughout. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ai-config) - -;; Dynamic vars gptel would normally own. -(defvar gptel-backend nil) -(defvar gptel-model nil) -(defvar gptel-prompt-prefix-alist nil) - -;;; cj/gptel--refresh-org-prefix - -(ert-deftest test-ai-config-refresh-org-prefix-updates-alist-entry () - "Normal: the advice refreshes the org-mode entry in the prefix alist." - (let ((gptel-prompt-prefix-alist '((org-mode . "stale\n")))) - (cj/gptel--refresh-org-prefix) - (let ((entry (alist-get 'org-mode gptel-prompt-prefix-alist))) - (should (stringp entry)) - ;; Fresh prefix includes the user-login-name + a timestamp bracket. - (should (string-match-p "\\[" entry))))) - -;;; cj/gptel-backend-and-model - -(ert-deftest test-ai-config-backend-and-model-formats-with-vector-backend () - "Normal: a vector backend's name element comes through formatted." - (let ((gptel-backend [unused-slot "Claude" other]) - (gptel-model 'claude-opus-4-6)) - (let ((s (cj/gptel-backend-and-model))) - (should (string-match-p "Claude" s)) - (should (string-match-p "claude-opus-4-6" s))))) - -(ert-deftest test-ai-config-backend-and-model-falls-back-to-ai-when-no-backend () - "Boundary: with no backend bound, the string starts with the AI fallback." - (let ((gptel-backend nil) - (gptel-model nil)) - (should (string-prefix-p "AI:" (cj/gptel-backend-and-model))))) - -;;; cj/gptel-switch-backend - -(ert-deftest test-ai-config-switch-backend-sets-backend-and-model () - "Normal: switch picks a backend + model, then updates the gptel vars." - (let ((gptel-backend nil) - (gptel-model nil) - (msg nil)) - (cl-letf (((symbol-function 'cj/gptel--available-backends) - (lambda () - '(("Anthropic - Claude" . anthropic-backend)))) - ((symbol-function 'gptel-backend-models) - (lambda (_b) '(claude-opus claude-sonnet))) - ((symbol-function 'completing-read) - (lambda (prompt collection &rest _) - ;; First call -> backend choice; second -> model. - (cond - ((string-match-p "backend" prompt) "Anthropic - Claude") - (t "claude-opus")))) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/gptel-switch-backend)) - (should (eq gptel-backend 'anthropic-backend)) - (should (equal gptel-model "claude-opus")) - (should (string-match-p "Anthropic - Claude" msg)))) - -(ert-deftest test-ai-config-switch-backend-error-invalid-choice () - "Error: an unrecognized backend name signals user-error." - (cl-letf (((symbol-function 'cj/gptel--available-backends) - (lambda () '(("Anthropic - Claude" . backend-a)))) - ((symbol-function 'completing-read) - (lambda (&rest _) "Something Else"))) - (should-error (cj/gptel-switch-backend) :type 'user-error))) - -;;; cj/gptel-add-buffer-file - -(ert-deftest test-ai-config-add-buffer-file-adds-when-buffer-has-file () - "Normal: a buffer that visits a file -> the file is added to context." - (let ((added nil)) - (with-temp-buffer - (setq buffer-file-name "/tmp/sample.org") - (cl-letf (((symbol-function 'completing-read) - (lambda (&rest _) (buffer-name))) - ((symbol-function 'cj/gptel--add-file-to-context) - (lambda (f) (setq added f) t)) - ((symbol-function 'message) #'ignore)) - (cj/gptel-add-buffer-file)) - (setq buffer-file-name nil)) - (should (equal added "/tmp/sample.org")))) - -(ert-deftest test-ai-config-add-buffer-file-messages-when-no-file () - "Boundary: a buffer not visiting a file -> message, no add call." - (let ((added nil) - (msg nil)) - (with-temp-buffer - (cl-letf (((symbol-function 'completing-read) - (lambda (&rest _) (buffer-name))) - ((symbol-function 'cj/gptel--add-file-to-context) - (lambda (f) (setq added f) t)) - ((symbol-function 'message) - (lambda (fmt &rest args) - (setq msg (apply #'format fmt args))))) - (cj/gptel-add-buffer-file))) - (should-not added) - (should (string-match-p "not visiting" msg)))) - -;;; cj/gptel-add-this-buffer - -(ert-deftest test-ai-config-add-this-buffer-calls-gptel-add-with-prefix () - "Normal: `cj/gptel-add-this-buffer' calls `gptel-add' with the (4) prefix arg." - (let ((arg nil)) - (cl-letf (((symbol-function 'featurep) (lambda (_) t)) - ((symbol-function 'gptel-add) - (lambda (a) (setq arg a))) - ((symbol-function 'message) #'ignore)) - (with-temp-buffer - (cj/gptel-add-this-buffer))) - (should (equal arg '(4))))) - -;;; cj/toggle-gptel - -(ert-deftest test-ai-config-toggle-gptel-closes-when-window-shown () - "Normal: with a window already displaying *AI-Assistant*, toggle deletes it." - (let* ((buf (generate-new-buffer "*AI-Assistant*")) - (deleted nil)) - (unwind-protect - (cl-letf (((symbol-function 'get-buffer-window) - (lambda (_b) 'fake-window)) - ((symbol-function 'delete-window) - (lambda (w) (setq deleted w)))) - (cj/toggle-gptel)) - (when (buffer-live-p buf) (kill-buffer buf))) - (should (eq deleted 'fake-window)))) - -(provide 'test-ai-config-gptel-commands) -;;; test-ai-config-gptel-commands.el ends here diff --git a/tests/test-ai-config-gptel-local-tools.el b/tests/test-ai-config-gptel-local-tools.el deleted file mode 100644 index 8d3a45ac4..000000000 --- a/tests/test-ai-config-gptel-local-tools.el +++ /dev/null @@ -1,57 +0,0 @@ -;;; test-ai-config-gptel-local-tools.el --- Tests for local GPTel tool loading -*- lexical-binding: t; -*- - -;;; Commentary: - -;; Tests for optional local GPTel tool loading from ai-config.el. - -;;; Code: - -(require 'ert) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(setq load-prefer-newer t) -(require 'testutil-ai-config) -(require 'ai-config) - -(defun test-ai-config-gptel-local-tools--write-tool (dir feature) - "Write a temporary tool module named FEATURE into DIR." - (let ((file (expand-file-name (format "%s.el" feature) dir))) - (write-region - (format ";;; %s.el --- test tool -*- lexical-binding: t; -*-\n(provide '%s)\n" - feature feature) - nil - file - nil - 'silent))) - -(ert-deftest test-ai-config-gptel-local-tools-missing-directory-is-non-fatal () - "Missing optional tool directory should not signal or load anything." - (let ((dir (expand-file-name "missing-gptel-tools/" - (make-temp-file "gptel-tools-home-" t)))) - (should-not (cj/gptel-load-local-tools dir '(test_missing_tool))))) - -(ert-deftest test-ai-config-gptel-local-tools-loads-present-tools () - "Present tool modules should be loaded and returned in request order." - (let ((dir (make-temp-file "gptel-tools-" t)) - (features '(test_gptel_tool_one test_gptel_tool_two))) - (dolist (feature features) - (test-ai-config-gptel-local-tools--write-tool dir feature)) - (should (equal (cj/gptel-load-local-tools dir features) - features)) - (dolist (feature features) - (should (featurep feature))))) - -(ert-deftest test-ai-config-gptel-local-tools-skips-missing-tool-files () - "Missing optional tool files should not prevent present tools from loading." - (let ((dir (make-temp-file "gptel-tools-" t)) - (present 'test_gptel_present_tool) - (missing 'test_gptel_missing_tool)) - (test-ai-config-gptel-local-tools--write-tool dir present) - (should (equal (cj/gptel-load-local-tools dir (list present missing)) - (list present))) - (should (featurep present)) - (should-not (featurep missing)))) - -(provide 'test-ai-config-gptel-local-tools) -;;; test-ai-config-gptel-local-tools.el ends here diff --git a/tests/test-ai-config-gptel-magit-lazy-loading.el b/tests/test-ai-config-gptel-magit-lazy-loading.el deleted file mode 100644 index 6eac0d193..000000000 --- a/tests/test-ai-config-gptel-magit-lazy-loading.el +++ /dev/null @@ -1,151 +0,0 @@ -;;; test-ai-config-gptel-magit-lazy-loading.el --- Tests for gptel-magit lazy loading -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the per-feature lazy gptel-magit integration in ai-config.el. -;; -;; ai-config.el uses three separate `with-eval-after-load' blocks -- -;; one per actual dependency -- to wire up its bindings: -;; git-commit -> M-g in `git-commit-mode-map' -;; magit-commit -> "g" suffix in the `magit-commit' transient -;; magit-diff -> "x" suffix in the `magit-diff' transient -;; -;; This shape matters: `magit.el' calls `(provide 'magit)' before its -;; `cl-eval-when (load eval) ...' block requires `magit-commit' and -;; `magit-stash', so a single `with-eval-after-load 'magit' would fire -;; while the transient prefixes the wiring references are still -;; undefined. `transient-append-suffix' silently no-ops on missing -;; prefixes, which is how that bug stayed invisible. -;; -;; Testing approach. In Emacs 30, `provide' does NOT fire registered -;; `eval-after-load' callbacks in batch mode -- only an actual `load' -;; does. Rather than work around that with disk-backed stub files, the -;; tests inspect `after-load-alist' directly to verify which features -;; the wiring is gated on. That's stronger evidence than running the -;; callbacks anyway: the regression we're guarding against is "wiring -;; hooked on `magit'," and the right shape of that check is "no entry -;; for `magit', entries for `git-commit', `magit-commit', `magit-diff'." - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) - -;; Load gptel stubs. This does NOT provide any of the magit features, -;; so the eval-after-load blocks in ai-config stay dormant. -(require 'testutil-ai-config) - -;; Stub the keymap used by the M-g binding. -(defvar git-commit-mode-map (make-sparse-keymap) - "Stub keymap standing in for magit's git-commit-mode-map.") - -;; Stub transient-append-suffix as a recorder. We don't invoke it -;; through provide in this test file, but the symbol must be fbound so -;; ai-config.el byte-compiles cleanly through `(require 'ai-config)'. -(unless (fboundp 'transient-append-suffix) - (defun transient-append-suffix (&rest _) nil)) - -(require 'ai-config) - -;; ----------------------------- Regression check ------------------------------ - -(ert-deftest test-ai-config-gptel-magit-regression-no-after-load-on-magit () - "ai-config must NOT register a `with-eval-after-load 'magit' hook. -`magit.el' provides itself BEFORE it loads `magit-commit' and -`magit-stash', so wiring keyed on `magit' would fire while the -transient prefixes are still undefined and `transient-append-suffix' -would silently no-op. The per-feature hooks side-step the race -entirely -- this test guards against any future regression that -re-introduces a single `'magit' hook." - ;; Forge installs an after-load entry for 'magit-mode'; magit's own - ;; code does not register anything keyed on the bare 'magit' symbol. - ;; Our wiring must not either. - (let ((entry (assoc 'magit after-load-alist))) - ;; If something else (e.g. another package) registers under 'magit - ;; the entry will exist, but it must not contain a closure that - ;; refers to gptel-magit symbols. Stringify the entry and grep. - (when entry - (should-not (string-match-p "gptel-magit" (format "%s" entry)))))) - -;; ------------------------------ Wiring registration -------------------------- - -(ert-deftest test-ai-config-gptel-magit-lazy-loading-git-commit-hook-registered () - "ai-config registers an `eval-after-load' hook keyed on `git-commit'. -The hook body binds M-g in `git-commit-mode-map' to -`gptel-magit-generate-message', so the printed closure mentions both." - (let ((entry (assoc 'git-commit after-load-alist))) - (should entry) - (let ((printed (format "%s" entry))) - (should (string-match-p "git-commit-mode-map" printed)) - (should (string-match-p "gptel-magit-generate-message" printed))))) - -(ert-deftest test-ai-config-gptel-magit-lazy-loading-magit-commit-hook-registered () - "ai-config registers an `eval-after-load' hook keyed on `magit-commit'. -The hook body calls `transient-append-suffix' for `magit-commit', so -the printed closure mentions both." - (let ((entry (assoc 'magit-commit after-load-alist))) - (should entry) - (let ((printed (format "%s" entry))) - (should (string-match-p "transient-append-suffix" printed)) - (should (string-match-p "magit-commit" printed)) - (should (string-match-p "gptel-magit-commit-generate" printed))))) - -(ert-deftest test-ai-config-gptel-magit-lazy-loading-magit-diff-hook-registered () - "ai-config registers an `eval-after-load' hook keyed on `magit-diff'. -The hook body calls `transient-append-suffix' for `magit-diff', so the -printed closure mentions both." - (let ((entry (assoc 'magit-diff after-load-alist))) - (should entry) - (let ((printed (format "%s" entry))) - (should (string-match-p "transient-append-suffix" printed)) - (should (string-match-p "magit-diff" printed)) - (should (string-match-p "gptel-magit-diff-explain" printed))))) - -;;; Normal Cases — Autoloads - -(ert-deftest test-ai-config-gptel-magit-lazy-loading-normal-generate-message-is-autoload () - "After ai-config loads, `gptel-magit-generate-message' is an autoload. -An autoload means the function is registered but `gptel-magit.el' has -not been loaded yet -- it loads only when the function is first -called." - (should (fboundp 'gptel-magit-generate-message)) - (should (autoloadp (symbol-function 'gptel-magit-generate-message)))) - -(ert-deftest test-ai-config-gptel-magit-lazy-loading-normal-commit-generate-is-autoload () - "After ai-config loads, `gptel-magit-commit-generate' is an autoload." - (should (fboundp 'gptel-magit-commit-generate)) - (should (autoloadp (symbol-function 'gptel-magit-commit-generate)))) - -(ert-deftest test-ai-config-gptel-magit-lazy-loading-normal-diff-explain-is-autoload () - "After ai-config loads, `gptel-magit-diff-explain' is an autoload." - (should (fboundp 'gptel-magit-diff-explain)) - (should (autoloadp (symbol-function 'gptel-magit-diff-explain)))) - -;;; Boundary Cases - -(ert-deftest test-ai-config-gptel-magit-lazy-loading-boundary-gptel-magit-not-loaded () - "After ai-config loads, `gptel-magit' itself stays unloaded. -The autoloads are registered so the package only loads when one of its -entry points is invoked." - (should-not (featurep 'gptel-magit))) - -;;; Error Cases — Install behavior - -(ert-deftest test-ai-config-gptel-magit-declared-via-use-package () - "ai-config declares gptel-magit via `use-package' so it gets installed. -Raw `(autoload ...)' calls register the function name but leave the -package uninstalled on machines that never ran `package-install'. The -\\=`use-package' form inherits `use-package-always-ensure' from -early-init, which is how every other package in this config gets -onto `load-path' before its autoloads fire." - (let ((source-file (expand-file-name "modules/ai-config.el" - user-emacs-directory))) - (with-temp-buffer - (insert-file-contents source-file) - (goto-char (point-min)) - (should (re-search-forward "(use-package gptel-magit\\b" nil t))))) - -(provide 'test-ai-config-gptel-magit-lazy-loading) -;;; test-ai-config-gptel-magit-lazy-loading.el ends here diff --git a/tests/test-ai-config-helpers.el b/tests/test-ai-config-helpers.el deleted file mode 100644 index cdbc0f6eb..000000000 --- a/tests/test-ai-config-helpers.el +++ /dev/null @@ -1,183 +0,0 @@ -;;; test-ai-config-helpers.el --- Tests for ai-config helper functions -*- lexical-binding: t; -*- - -;;; Commentary: -;; Covers helpers that don't depend on a live gptel install: -;; -;; cj/auth-source-secret -;; cj/anthropic-api-key (caching wrapper) -;; cj/openai-api-key (caching wrapper) -;; cj/gptel--add-file-to-context -;; cj/gptel-clear-buffer -;; cj/gptel-context-clear -;; cj/gptel-insert-model-heading -;; -;; External primitives (`auth-source-search', `gptel-add-file', etc.) -;; are stubbed so the tests never touch the keyring or the network. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ai-config) - -;; Make `gptel-context--alist' a real dynamic variable for the fallback -;; test below. Under lexical-binding a plain `let' is lexical, so the -;; `setq' inside `cj/gptel-context-clear' would otherwise miss it. -(defvar gptel-context--alist nil - "Dynamic stand-in for the gptel-context alist (gptel not loaded here).") - -;;; cj/auth-source-secret - -(ert-deftest test-ai-config-auth-source-secret-returns-string () - "Normal: a plain-string secret comes back as-is." - (cl-letf (((symbol-function 'auth-source-search) - (lambda (&rest _) '((:secret "plaintext"))))) - (should (equal (cj/auth-source-secret "example.com" "user") - "plaintext")))) - -(ert-deftest test-ai-config-auth-source-secret-unwraps-function () - "Normal: a function secret is funcall'd to retrieve the value." - (cl-letf (((symbol-function 'auth-source-search) - (lambda (&rest _) (list (list :secret (lambda () "called")))))) - (should (equal (cj/auth-source-secret "example.com" "user") - "called")))) - -(ert-deftest test-ai-config-auth-source-secret-errors-when-missing () - "Error: an empty result raises a clear error." - (cl-letf (((symbol-function 'auth-source-search) - (lambda (&rest _) nil))) - (should-error (cj/auth-source-secret "nope.example.com" "user") - :type 'error))) - -;;; cj/anthropic-api-key / cj/openai-api-key - -(ert-deftest test-ai-config-anthropic-api-key-caches-after-first-call () - "Normal: a subsequent call returns the cached value without re-fetching." - (let ((cj/anthropic-api-key-cached nil) - (call-count 0)) - (cl-letf (((symbol-function 'auth-source-search) - (lambda (&rest _) - (cl-incf call-count) - '((:secret "anth-key"))))) - (should (equal (cj/anthropic-api-key) "anth-key")) - (should (equal (cj/anthropic-api-key) "anth-key")) - (should (= call-count 1))))) - -(ert-deftest test-ai-config-openai-api-key-caches-after-first-call () - "Normal: same caching contract as the anthropic key." - (let ((cj/openai-api-key-cached nil) - (call-count 0)) - (cl-letf (((symbol-function 'auth-source-search) - (lambda (&rest _) - (cl-incf call-count) - '((:secret "oai-key"))))) - (should (equal (cj/openai-api-key) "oai-key")) - (should (equal (cj/openai-api-key) "oai-key")) - (should (= call-count 1))))) - -;;; cj/gptel--add-file-to-context - -(ert-deftest test-ai-config-add-file-to-context-adds-existing-file () - "Normal: an existing file is added and the function returns t." - (let ((tmp (make-temp-file "ai-config-add-file-"))) - (unwind-protect - (let ((gptel-context--alist nil) - (added nil)) - (cl-letf (((symbol-function 'gptel-add-file) - (lambda (f) (setq added f))) - ((symbol-function 'message) #'ignore)) - (should (eq (cj/gptel--add-file-to-context tmp) t)) - (should (equal added tmp)))) - (delete-file tmp)))) - -(ert-deftest test-ai-config-add-file-to-context-skips-missing-file () - "Boundary: a non-existent path returns nil and doesn't call gptel-add-file." - (let ((called nil)) - (cl-letf (((symbol-function 'gptel-add-file) - (lambda (_) (setq called t)))) - (should-not (cj/gptel--add-file-to-context "/no/such/path")) - (should-not called)))) - -(ert-deftest test-ai-config-add-file-to-context-skips-nil-path () - "Boundary: a nil path returns nil without calling gptel-add-file." - (let ((called nil)) - (cl-letf (((symbol-function 'gptel-add-file) - (lambda (_) (setq called t)))) - (should-not (cj/gptel--add-file-to-context nil)) - (should-not called)))) - -;;; cj/gptel-clear-buffer - -(ert-deftest test-ai-config-clear-buffer-erases-in-gptel-org-buffer () - "Normal: a gptel-mode org buffer is erased and the fresh org prefix is reinserted." - (with-temp-buffer - (delay-mode-hooks (org-mode)) - (setq-local gptel-mode t) - (insert "* Existing conversation\nstuff\n") - (let ((msg nil)) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) - (setq msg (apply #'format fmt args))))) - (cj/gptel-clear-buffer)) - (should (string-match-p "cleared" msg))) - ;; The fresh prefix is an org heading starting with "* ". - (should (string-prefix-p "* " (buffer-string))) - (should-not (string-match-p "Existing conversation" (buffer-string))))) - -(ert-deftest test-ai-config-clear-buffer-noop-when-not-gptel-org () - "Boundary: in a non-gptel buffer the function messages and changes nothing." - (with-temp-buffer - (insert "untouched\n") - (let ((msg nil)) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) - (setq msg (apply #'format fmt args))))) - (cj/gptel-clear-buffer)) - (should (string-match-p "Not a GPTel buffer" msg)) - (should (equal (buffer-string) "untouched\n"))))) - -;;; cj/gptel-context-clear - -(ert-deftest test-ai-config-context-clear-uses-remove-all-when-available () - "Normal: when `gptel-context-remove-all' is bound, it wins the cond. -The stub must be a command because `cj/gptel-context-clear' invokes it -via `call-interactively'." - (let ((called nil) - (msg nil)) - (cl-letf (((symbol-function 'gptel-context-remove-all) - (lambda () (interactive) (setq called 'remove-all))) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/gptel-context-clear)) - (should (eq called 'remove-all)) - (should (string-match-p "cleared" msg)))) - -(ert-deftest test-ai-config-context-clear-falls-back-to-alist-setq () - "Boundary: when no clearing function exists, the alist is set to nil." - (let ((gptel-context--alist '((:dummy))) - (msg nil)) - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) - (not (memq sym '(gptel-context-remove-all gptel-context-clear))))) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/gptel-context-clear)) - (should (null gptel-context--alist)) - (should (string-match-p "cleared" msg)))) - -;;; cj/gptel-insert-model-heading - -(ert-deftest test-ai-config-insert-model-heading-inserts-at-given-position () - "Normal: an Org heading is inserted at RESPONSE-BEGIN-POS." - (with-temp-buffer - (insert "response text") - (cl-letf (((symbol-function 'cj/gptel-backend-and-model) - (lambda () "Anthropic: claude-test [2026-05-13 12:00:00]"))) - (cj/gptel-insert-model-heading (point-min) (point-max))) - (should (string-prefix-p "* Anthropic: claude-test" (buffer-string))) - (should (string-match-p "\nresponse text" (buffer-string))))) - -(provide 'test-ai-config-helpers) -;;; test-ai-config-helpers.el ends here diff --git a/tests/test-ai-config-model-to-string.el b/tests/test-ai-config-model-to-string.el deleted file mode 100644 index aa1149272..000000000 --- a/tests/test-ai-config-model-to-string.el +++ /dev/null @@ -1,60 +0,0 @@ -;;; test-ai-config-model-to-string.el --- Tests for cj/gptel--model-to-string -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for cj/gptel--model-to-string from ai-config.el. -;; -;; Pure function that converts a model identifier (string, symbol, or -;; other type) to a string representation. Branches on input type: -;; string (identity), symbol (symbol-name), fallback (format). - -;;; Code: - -(require 'ert) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'testutil-ai-config) -(require 'ai-config) - -;;; Normal Cases - -(ert-deftest test-ai-config-model-to-string-normal-string-returns-string () - "String model name should be returned unchanged." - (should (equal (cj/gptel--model-to-string "claude-opus-4-6") "claude-opus-4-6"))) - -(ert-deftest test-ai-config-model-to-string-normal-symbol-returns-symbol-name () - "Symbol model name should return its symbol-name." - (should (equal (cj/gptel--model-to-string 'gpt-4o) "gpt-4o"))) - -(ert-deftest test-ai-config-model-to-string-normal-number-returns-formatted () - "Numeric input should be formatted as a string." - (should (equal (cj/gptel--model-to-string 42) "42"))) - -;;; Boundary Cases - -(ert-deftest test-ai-config-model-to-string-boundary-empty-string-returns-empty () - "Empty string should be returned as empty string." - (should (equal (cj/gptel--model-to-string "") ""))) - -(ert-deftest test-ai-config-model-to-string-boundary-nil-returns-nil-string () - "Nil is a symbol, so should return \"nil\"." - (should (equal (cj/gptel--model-to-string nil) "nil"))) - -(ert-deftest test-ai-config-model-to-string-boundary-keyword-symbol-includes-colon () - "Keyword symbol should return its name including the colon." - (should (equal (cj/gptel--model-to-string :some-model) ":some-model"))) - -(ert-deftest test-ai-config-model-to-string-boundary-list-uses-format-fallback () - "List input should hit the fallback format branch." - (should (equal (cj/gptel--model-to-string '(a b)) "(a b)"))) - -(ert-deftest test-ai-config-model-to-string-boundary-vector-uses-format-fallback () - "Vector input should hit the fallback format branch." - (should (equal (cj/gptel--model-to-string [1 2]) "[1 2]"))) - -(ert-deftest test-ai-config-model-to-string-boundary-string-with-spaces-unchanged () - "String with spaces should be returned unchanged." - (should (equal (cj/gptel--model-to-string "model with spaces") "model with spaces"))) - -(provide 'test-ai-config-model-to-string) -;;; test-ai-config-model-to-string.el ends here diff --git a/tests/test-ai-conversations-browser.el b/tests/test-ai-conversations-browser.el deleted file mode 100644 index d7422b096..000000000 --- a/tests/test-ai-conversations-browser.el +++ /dev/null @@ -1,244 +0,0 @@ -;;; test-ai-conversations-browser.el --- Tests for ai-conversations-browser -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the saved-conversations browser. Pure helpers (topic -;; parsing, header stripping, preview, rename target) are tested -;; against fixed inputs. File-touching actions (load / delete / -;; rename) are tested against a temp conversations directory. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) - -(require 'testutil-ai-config) -;; Force real ai-conversations to override testutil's stub. -(setq features (delq 'ai-conversations features)) -(require 'ai-conversations) -(require 'ai-conversations-browser) - -;; ----------------------------- temp-dir helper - -(defun test-ai-conversations-browser--with-temp-dir (fn) - "Run FN inside a fresh conversations directory. Clean up after." - (let* ((dir (make-temp-file "test-ai-conversations-browser-" t)) - (cj/gptel-conversations-directory dir)) - (unwind-protect - (funcall fn dir) - (when (file-exists-p dir) - (delete-directory dir t))))) - -(defun test-ai-conversations-browser--write (dir name content) - "Write CONTENT to NAME in DIR. Return the absolute path." - (let ((path (expand-file-name name dir))) - (with-temp-file path (insert content)) - path)) - -;; ----------------------------- topic-from-filename - -(ert-deftest test-ai-conversations-browser-topic-normal () - "Normal: topic slug extracted from a well-formed filename." - (should (equal (cj/gptel-browser--topic-from-filename - "my-topic_20260315-101530.gptel") - "my-topic"))) - -(ert-deftest test-ai-conversations-browser-topic-error-malformed () - "Boundary: malformed filename returns nil." - (should-not (cj/gptel-browser--topic-from-filename "garbage.gptel")) - (should-not (cj/gptel-browser--topic-from-filename "topic.gptel")) - (should-not (cj/gptel-browser--topic-from-filename "topic_20260315.gptel"))) - -;; ----------------------------- strip-headers - -(ert-deftest test-ai-conversations-browser-strip-headers-normal () - "Strip the two visibility headers plus the blank line after them." - (should (equal (cj/gptel-browser--strip-headers - "#+STARTUP: showeverything\n#+VISIBILITY: all\n\nrest\n") - "rest\n"))) - -(ert-deftest test-ai-conversations-browser-strip-headers-no-headers () - "Boundary: input without headers is unchanged." - (should (equal (cj/gptel-browser--strip-headers "plain body\n") - "plain body\n"))) - -;; ----------------------------- last-message - -(ert-deftest test-ai-conversations-browser-last-message-normal () - "Last-message picks the body of the last org heading." - (let ((text "* user [2026-01-01]\nhello there\n* AI [2026-01-01]\nthe latest reply\n")) - (should (equal (cj/gptel-browser--last-message text) - "the latest reply")))) - -(ert-deftest test-ai-conversations-browser-last-message-no-heading () - "Boundary: text without headings returns the (collapsed) body." - (let ((text "just some body\nwith two lines\n")) - (should (equal (cj/gptel-browser--last-message text) - "just some body with two lines")))) - -;; ----------------------------- preview - -(ert-deftest test-ai-conversations-browser-preview-truncates () - "Preview is ellipsized when the message is longer than LENGTH." - (let ((text "* AI\nthis is a very long response that should get truncated for the preview\n")) - (let ((preview (cj/gptel-browser--preview text 30))) - (should (= (length preview) 30)) - (should (string-suffix-p "…" preview))))) - -(ert-deftest test-ai-conversations-browser-preview-short () - "Preview is returned verbatim when shorter than LENGTH." - (let ((text "* AI\nshort\n")) - (should (equal (cj/gptel-browser--preview text 60) "short")))) - -(ert-deftest test-ai-conversations-browser-preview-empty () - "Preview of empty body returns empty string." - (should (equal (cj/gptel-browser--preview "" 60) ""))) - -;; ----------------------------- row-for-file - -(ert-deftest test-ai-conversations-browser-row-for-file-normal () - "Row contains date, topic, and a preview; carries file metadata." - (test-ai-conversations-browser--with-temp-dir - (lambda (dir) - (let ((file (test-ai-conversations-browser--write - dir "alpha_20260315-101530.gptel" - "#+STARTUP: showeverything\n\n* AI\nresult body\n"))) - (let ((row (cj/gptel-browser--row-for-file file dir))) - (should row) - (should (string-match-p "2026-03-15 10:15" row)) - (should (string-match-p "alpha" row)) - (should (string-match-p "result body" row)) - (should (equal (get-text-property 0 'cj/gptel-browser-file row) - "alpha_20260315-101530.gptel"))))))) - -(ert-deftest test-ai-conversations-browser-row-for-file-non-conversation () - "Files that don't match the conversation pattern return nil." - (test-ai-conversations-browser--with-temp-dir - (lambda (dir) - (let ((file (test-ai-conversations-browser--write - dir "not-a-conversation.gptel" "body"))) - (should-not (cj/gptel-browser--row-for-file file dir)))))) - -;; ----------------------------- rows / render - -(ert-deftest test-ai-conversations-browser-rows-from-empty-dir () - "Empty conversations directory yields no rows." - (test-ai-conversations-browser--with-temp-dir - (lambda (_dir) - (should-not (cj/gptel-browser--rows))))) - -(ert-deftest test-ai-conversations-browser-rows-multiple-conversations () - "Multiple conversations produce a row per file." - (test-ai-conversations-browser--with-temp-dir - (lambda (dir) - (test-ai-conversations-browser--write - dir "a_20260101-100000.gptel" "* AI\nfirst\n") - (test-ai-conversations-browser--write - dir "b_20260102-100000.gptel" "* AI\nsecond\n") - (let ((rows (cj/gptel-browser--rows))) - (should (= 2 (length rows))))))) - -(ert-deftest test-ai-conversations-browser-render-empty () - "Render shows a 'no conversations' line when directory is empty." - (test-ai-conversations-browser--with-temp-dir - (lambda (_dir) - (with-temp-buffer - (cj/gptel-browser-mode) - (cj/gptel-browser--render) - (should (string-match-p "no saved conversations" (buffer-string))))))) - -(ert-deftest test-ai-conversations-browser-render-newest-first () - "Render sorts rows newest first by timestamp." - (test-ai-conversations-browser--with-temp-dir - (lambda (dir) - (test-ai-conversations-browser--write - dir "old_20260101-100000.gptel" "* AI\nx\n") - (test-ai-conversations-browser--write - dir "new_20260301-100000.gptel" "* AI\ny\n") - (with-temp-buffer - (cj/gptel-browser-mode) - (cj/gptel-browser--render) - (let ((text (buffer-substring-no-properties (point-min) (point-max)))) - ;; New (March) should appear before old (January) in the buffer. - (should (< (string-match "2026-03-01" text) - (string-match "2026-01-01" text)))))))) - -;; ----------------------------- rename-target - -(ert-deftest test-ai-conversations-browser-rename-target-normal () - "Rename-target preserves the timestamp and slugifies the new topic." - (should (equal (cj/gptel-browser--rename-target - "/tmp/old-topic_20260101-100000.gptel" - "Brand New Topic") - "/tmp/brand-new-topic_20260101-100000.gptel"))) - -(ert-deftest test-ai-conversations-browser-rename-target-error-no-timestamp () - "Rename-target errors when the filename lacks a timestamp." - (should-error (cj/gptel-browser--rename-target "/tmp/no-ts.gptel" "x"))) - -;; ----------------------------- delete / rename actions - -(ert-deftest test-ai-conversations-browser-delete-removes-file () - "Delete with y removes the file under point and re-renders." - (test-ai-conversations-browser--with-temp-dir - (lambda (dir) - (let ((file (test-ai-conversations-browser--write - dir "topic_20260101-100000.gptel" "* AI\nx\n"))) - (with-temp-buffer - (cj/gptel-browser-mode) - (cj/gptel-browser--render) - ;; Point on the only data row - (goto-char (point-min)) - (forward-line 2) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) t))) - (cj/gptel-browser-delete)) - (should-not (file-exists-p file))))))) - -(ert-deftest test-ai-conversations-browser-delete-cancel-keeps-file () - "Delete with n leaves the file alone." - (test-ai-conversations-browser--with-temp-dir - (lambda (dir) - (let ((file (test-ai-conversations-browser--write - dir "topic_20260101-100000.gptel" "* AI\nx\n"))) - (with-temp-buffer - (cj/gptel-browser-mode) - (cj/gptel-browser--render) - (goto-char (point-min)) - (forward-line 2) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (&rest _) nil))) - (cj/gptel-browser-delete)) - (should (file-exists-p file))))))) - -(ert-deftest test-ai-conversations-browser-rename-renames-file () - "Rename moves the file under a new slug while preserving timestamp." - (test-ai-conversations-browser--with-temp-dir - (lambda (dir) - (let* ((file (test-ai-conversations-browser--write - dir "old-name_20260101-100000.gptel" "* AI\nx\n"))) - (with-temp-buffer - (cj/gptel-browser-mode) - (cj/gptel-browser--render) - (goto-char (point-min)) - (forward-line 2) - (cl-letf (((symbol-function 'read-string) - (lambda (&rest _) "renamed topic"))) - (cj/gptel-browser-rename)) - (should-not (file-exists-p file)) - (should (file-exists-p - (expand-file-name "renamed-topic_20260101-100000.gptel" - dir)))))))) - -(ert-deftest test-ai-conversations-browser-rename-error-on-empty-line () - "Rename errors when point is on the header/empty area." - (test-ai-conversations-browser--with-temp-dir - (lambda (_dir) - (with-temp-buffer - (cj/gptel-browser-mode) - (cj/gptel-browser--render) - (goto-char (point-min)) - (should-error (cj/gptel-browser-rename)))))) - -(provide 'test-ai-conversations-browser) -;;; test-ai-conversations-browser.el ends here diff --git a/tests/test-ai-conversations.el b/tests/test-ai-conversations.el deleted file mode 100644 index 2d5aefd13..000000000 --- a/tests/test-ai-conversations.el +++ /dev/null @@ -1,564 +0,0 @@ -;;; test-ai-conversations.el --- Tests for ai-conversations.el -*- lexical-binding: t; -*- - -;;; Commentary: -;; Normal / Boundary / Error tests for the save/load/delete and -;; autosave surface in ai-conversations.el. Pure helpers are tested -;; against fixed inputs; file-touching helpers use per-test temp -;; directories. Interactive commands are exercised via `cl-letf' -;; stubs on `completing-read' and `y-or-n-p'. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) - -(require 'testutil-ai-config) -;; testutil-ai-config provides 'ai-conversations as a stub. Force the -;; real module to override. -(setq features (delq 'ai-conversations features)) -(require 'ai-conversations) - -;; -------------------------------------------------------- temp-dir helper - -(defun test-ai-conversations--with-temp-dir (fn) - "Run FN inside a fresh conversations directory. Clean up after." - (let* ((dir (make-temp-file "test-ai-conversations-" t)) - (cj/gptel-conversations-directory dir)) - (unwind-protect - (funcall fn dir) - (when (file-exists-p dir) - (delete-directory dir t))))) - -(defun test-ai-conversations--touch (dir name) - "Create empty file NAME in DIR." - (let ((path (expand-file-name name dir))) - (with-temp-file path (insert "")) - path)) - -;; ------------------------------------------------------ slugify-topic - -(ert-deftest test-ai-conversations-slugify-topic-normal () - "Normal: ASCII words with spaces become hyphen-joined slug." - (should (equal (cj/gptel--slugify-topic "Hello World") "hello-world"))) - -(ert-deftest test-ai-conversations-slugify-topic-boundary-empty () - "Boundary: empty input returns the literal \"conversation\" placeholder." - (should (equal (cj/gptel--slugify-topic "") "conversation")) - (should (equal (cj/gptel--slugify-topic nil) "conversation"))) - -(ert-deftest test-ai-conversations-slugify-topic-boundary-all-special () - "Boundary: input with no slug-safe chars falls back to placeholder." - (should (equal (cj/gptel--slugify-topic "!!!@@@###") "conversation")) - (should (equal (cj/gptel--slugify-topic " ") "conversation"))) - -(ert-deftest test-ai-conversations-slugify-topic-boundary-unicode-stripped () - "Boundary: non-ASCII characters drop out (only [a-z0-9] survives)." - (should (equal (cj/gptel--slugify-topic "Café Résumé") "caf-r-sum"))) - -(ert-deftest test-ai-conversations-slugify-topic-boundary-idempotent () - "Boundary: applying twice yields the same result as once." - (let ((once (cj/gptel--slugify-topic "Foo Bar 2026!"))) - (should (equal once (cj/gptel--slugify-topic once))))) - -(ert-deftest test-ai-conversations-slugify-topic-boundary-leading-trailing-trim () - "Boundary: leading/trailing separator runs are trimmed." - (should (equal (cj/gptel--slugify-topic "---foo---") "foo")) - (should (equal (cj/gptel--slugify-topic "**foo**") "foo"))) - -(ert-deftest test-ai-conversations-slugify-topic-normal-numbers-preserved () - "Normal: digits survive the slug." - (should (equal (cj/gptel--slugify-topic "Project 2026 Plan") - "project-2026-plan"))) - -;; ------------------------------------------------------ timestamp-from-filename - -(ert-deftest test-ai-conversations-timestamp-from-filename-normal () - "Normal: well-formed filename decodes to a time value." - (let ((ts (cj/gptel--timestamp-from-filename - "topic_20260315-101530.gptel"))) - (should ts) - (should (equal (format-time-string "%Y-%m-%d %H:%M:%S" ts) - "2026-03-15 10:15:30")))) - -(ert-deftest test-ai-conversations-timestamp-from-filename-boundary-year-edges () - "Boundary: end-of-year and start-of-year timestamps decode correctly." - (let ((eoy (cj/gptel--timestamp-from-filename - "topic_20251231-235959.gptel")) - (boy (cj/gptel--timestamp-from-filename - "topic_20260101-000000.gptel"))) - (should (equal (format-time-string "%Y-%m-%d %H:%M:%S" eoy) - "2025-12-31 23:59:59")) - (should (equal (format-time-string "%Y-%m-%d %H:%M:%S" boy) - "2026-01-01 00:00:00")))) - -(ert-deftest test-ai-conversations-timestamp-from-filename-error-malformed () - "Error: non-matching filename returns nil." - (should-not (cj/gptel--timestamp-from-filename "not-a-gptel-file")) - (should-not (cj/gptel--timestamp-from-filename "topic.gptel")) - (should-not (cj/gptel--timestamp-from-filename "topic_20260315.gptel")) - (should-not (cj/gptel--timestamp-from-filename "topic_2026031-101530.gptel"))) - -;; ------------------------------------------------------ existing-topics - -(ert-deftest test-ai-conversations-existing-topics-normal () - "Normal: returns unique topic slugs across multiple-timestamped files." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "foo_20260101-100000.gptel") - (test-ai-conversations--touch dir "foo_20260102-100000.gptel") - (test-ai-conversations--touch dir "bar_20260102-100000.gptel") - (let ((topics (cj/gptel--existing-topics))) - (should (member "foo" topics)) - (should (member "bar" topics)) - (should (= 2 (length topics))))))) - -(ert-deftest test-ai-conversations-existing-topics-boundary-empty-dir () - "Boundary: empty conversations directory returns nil." - (test-ai-conversations--with-temp-dir - (lambda (_dir) - (should-not (cj/gptel--existing-topics))))) - -(ert-deftest test-ai-conversations-existing-topics-boundary-missing-dir () - "Boundary: missing directory returns nil instead of erroring." - (let ((cj/gptel-conversations-directory - (expand-file-name (format "missing-%s" (random)) "/tmp"))) - (should-not (cj/gptel--existing-topics)))) - -(ert-deftest test-ai-conversations-existing-topics-boundary-ignores-non-gptel () - "Boundary: files without .gptel extension are ignored." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "foo_20260101-100000.gptel") - (test-ai-conversations--touch dir "readme.txt") - (test-ai-conversations--touch dir "stray.gptel.bak") - (should (equal (cj/gptel--existing-topics) '("foo")))))) - -;; ------------------------------------------------------ latest-file-for-topic - -(ert-deftest test-ai-conversations-latest-file-for-topic-normal () - "Normal: returns the newest file for the topic by lexical sort." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "foo_20260101-100000.gptel") - (test-ai-conversations--touch dir "foo_20260103-100000.gptel") - (test-ai-conversations--touch dir "foo_20260102-100000.gptel") - (should (equal (cj/gptel--latest-file-for-topic "foo") - "foo_20260103-100000.gptel"))))) - -(ert-deftest test-ai-conversations-latest-file-for-topic-boundary-no-match () - "Boundary: no matching topic returns nil." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "bar_20260101-100000.gptel") - (should-not (cj/gptel--latest-file-for-topic "foo"))))) - -(ert-deftest test-ai-conversations-latest-file-for-topic-boundary-missing-dir () - "Boundary: missing directory returns nil." - (let ((cj/gptel-conversations-directory - (expand-file-name (format "missing-%s" (random)) "/tmp"))) - (should-not (cj/gptel--latest-file-for-topic "foo")))) - -(ert-deftest test-ai-conversations-latest-file-for-topic-boundary-regex-isolation () - "Boundary: prefix-overlapping topics are not falsely matched." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "foo_20260101-100000.gptel") - (test-ai-conversations--touch dir "foobar_20260102-100000.gptel") - (should (equal (cj/gptel--latest-file-for-topic "foo") - "foo_20260101-100000.gptel"))))) - -;; ------------------------------------------------------ conversation-candidates - -(ert-deftest test-ai-conversations-conversation-candidates-normal-newest-first () - "Normal: candidates are sorted newest-first when configured that way." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "foo_20260101-100000.gptel") - (test-ai-conversations--touch dir "foo_20260103-100000.gptel") - (test-ai-conversations--touch dir "foo_20260102-100000.gptel") - (let ((cj/gptel-conversations-sort-order 'newest-first)) - (let* ((cands (cj/gptel--conversation-candidates)) - (files (mapcar #'cdr cands))) - (should (equal files - '("foo_20260103-100000.gptel" - "foo_20260102-100000.gptel" - "foo_20260101-100000.gptel")))))))) - -(ert-deftest test-ai-conversations-conversation-candidates-normal-oldest-first () - "Normal: candidates respect oldest-first sort order." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "foo_20260101-100000.gptel") - (test-ai-conversations--touch dir "foo_20260103-100000.gptel") - (test-ai-conversations--touch dir "foo_20260102-100000.gptel") - (let ((cj/gptel-conversations-sort-order 'oldest-first)) - (let* ((cands (cj/gptel--conversation-candidates)) - (files (mapcar #'cdr cands))) - (should (equal files - '("foo_20260101-100000.gptel" - "foo_20260102-100000.gptel" - "foo_20260103-100000.gptel")))))))) - -(ert-deftest test-ai-conversations-conversation-candidates-error-missing-dir () - "Error: missing conversations directory signals." - (let ((cj/gptel-conversations-directory - (expand-file-name (format "missing-%s" (random)) "/tmp"))) - (should-error (cj/gptel--conversation-candidates)))) - -(ert-deftest test-ai-conversations-conversation-candidates-display-shape () - "Display string is \"filename [YYYY-MM-DD HH:MM]\"." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (test-ai-conversations--touch dir "topic_20260315-101530.gptel") - (let* ((cands (cj/gptel--conversation-candidates)) - (display (car (car cands)))) - (should (string-match-p - "\\`topic_20260315-101530\\.gptel \\[2026-03-15 10:15\\]\\'" - display)))))) - -;; ------------------------------------------------------ save-buffer-to-file - -(ert-deftest test-ai-conversations-save-buffer-to-file-normal () - "Normal: writes buffer with visibility headers prepended." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (with-temp-buffer - (insert "hello world\n") - (let ((file (expand-file-name "out.gptel" dir))) - (cj/gptel--save-buffer-to-file (current-buffer) file) - (should (file-exists-p file)) - (with-temp-buffer - (insert-file-contents file) - (should (string-match-p "^#\\+STARTUP: showeverything" - (buffer-string))) - (should (string-match-p "^#\\+VISIBILITY: all" - (buffer-string))) - (should (string-match-p "hello world" - (buffer-string))))))))) - -(ert-deftest test-ai-conversations-save-buffer-to-file-roundtrip-with-strip () - "Round-trip: save then strip-visibility-headers yields original content." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((original "first line\nsecond line\n") - (file (expand-file-name "rt.gptel" dir))) - (with-temp-buffer - (insert original) - (cj/gptel--save-buffer-to-file (current-buffer) file)) - (with-temp-buffer - (insert-file-contents file) - (cj/gptel--strip-visibility-headers) - (should (equal (buffer-string) original))))))) - -(ert-deftest test-ai-conversations-strip-visibility-headers-boundary-no-headers () - "Boundary: buffer without headers is unchanged." - (with-temp-buffer - (insert "plain body\n") - (cj/gptel--strip-visibility-headers) - (should (equal (buffer-string) "plain body\n")))) - -;; ------------------------------------------------------ autosave-after-response - -(defmacro test-ai-conversations--with-gptel-mode (&rest body) - "Run BODY in a temp buffer with `gptel-mode' bound non-nil." - (declare (indent 0)) - `(with-temp-buffer - (setq-local gptel-mode t) - ,@body)) - -(ert-deftest test-ai-conversations-autosave-after-response-saves-when-enabled () - "Hook saves the buffer to the autosave filepath when enabled." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((file (expand-file-name "auto.gptel" dir))) - (test-ai-conversations--with-gptel-mode - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath file) - (insert "autosaved body") - (cj/gptel--autosave-after-response) - (should (file-exists-p file))))))) - -(ert-deftest test-ai-conversations-autosave-after-response-skips-when-disabled () - "Hook is a no-op when `cj/gptel-autosave-enabled' is nil." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((file (expand-file-name "auto.gptel" dir))) - (test-ai-conversations--with-gptel-mode - (setq-local cj/gptel-autosave-enabled nil) - (setq-local cj/gptel-autosave-filepath file) - (cj/gptel--autosave-after-response) - (should-not (file-exists-p file))))))) - -(ert-deftest test-ai-conversations-autosave-after-response-skips-when-no-filepath () - "Hook is a no-op when filepath is nil or empty." - (test-ai-conversations--with-temp-dir - (lambda (_dir) - (test-ai-conversations--with-gptel-mode - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath nil) - ;; Should not error - (cj/gptel--autosave-after-response)) - (test-ai-conversations--with-gptel-mode - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath "") - (cj/gptel--autosave-after-response))))) - -(ert-deftest test-ai-conversations-autosave-after-response-skips-outside-gptel-mode () - "Hook is a no-op when `gptel-mode' is nil." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((file (expand-file-name "auto.gptel" dir))) - (with-temp-buffer - (setq-local gptel-mode nil) - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath file) - (cj/gptel--autosave-after-response) - (should-not (file-exists-p file))))))) - -(ert-deftest test-ai-conversations-autosave-after-send-error-is-non-fatal () - "Hook surfaces a save error via `message' rather than signaling." - (test-ai-conversations--with-temp-dir - (lambda (_dir) - (test-ai-conversations--with-gptel-mode - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath "/nonexistent-dir/file.gptel") - ;; Must not signal even though the write will fail - (cj/gptel--autosave-after-send))))) - -;; ------------------------------------------------------ autosave timer - -(ert-deftest test-ai-conversations-autosave-start-timer-normal () - "Normal: starting autosave creates a repeating timer for the current buffer." - (with-temp-buffer - (setq-local gptel-mode t) - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath "/tmp/foo.gptel") - (let ((calls nil)) - (cl-letf (((symbol-function 'run-with-timer) - (lambda (secs repeat function &rest args) - (push (list secs repeat function args) calls) - :fake-timer))) - (let ((cj/gptel-autosave-interval 17)) - (cj/gptel--autosave-start-timer))) - (should (eq cj/gptel-autosave--timer :fake-timer)) - (should (equal (caar calls) 17)) - (should (equal (cadar calls) 17)) - (should (eq (nth 2 (car calls)) #'cj/gptel--autosave-timer-callback)) - (should (eq (car (nth 3 (car calls))) (current-buffer)))))) - -(ert-deftest test-ai-conversations-autosave-start-timer-idempotent () - "Boundary: starting autosave twice does not create a second timer." - (with-temp-buffer - (setq-local gptel-mode t) - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath "/tmp/foo.gptel") - (setq-local cj/gptel-autosave--timer :existing-timer) - (let ((created 0)) - (cl-letf (((symbol-function 'run-with-timer) - (lambda (&rest _) - (setq created (1+ created)) - :new-timer))) - (cj/gptel--autosave-start-timer)) - (should (= created 0)) - (should (eq cj/gptel-autosave--timer :existing-timer))))) - -(ert-deftest test-ai-conversations-autosave-stop-timer-cancels () - "Normal: stopping autosave cancels the current buffer's timer." - (with-temp-buffer - (setq-local cj/gptel-autosave--timer :fake-timer) - (let ((cancelled nil)) - (cl-letf (((symbol-function 'cancel-timer) - (lambda (timer) (setq cancelled timer)))) - (cj/gptel--autosave-stop-timer)) - (should (eq cancelled :fake-timer)) - (should-not cj/gptel-autosave--timer)))) - -(ert-deftest test-ai-conversations-autosave-timer-callback-saves-active-buffer () - "Normal: timer callback saves the live buffer when autosave is active." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((file (expand-file-name "timer.gptel" dir)) - (buf (generate-new-buffer " *gptel timer test*"))) - (unwind-protect - (with-current-buffer buf - (setq-local gptel-mode t) - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath file) - (insert "timer body") - (cj/gptel--autosave-timer-callback buf) - (should (file-exists-p file))) - (when (buffer-live-p buf) - (kill-buffer buf))))))) - -(ert-deftest test-ai-conversations-autosave-timer-callback-stops-inactive-buffer () - "Boundary: timer callback cancels itself when autosave is no longer active." - (let ((buf (generate-new-buffer " *gptel timer inactive*"))) - (unwind-protect - (with-current-buffer buf - (setq-local gptel-mode t) - (setq-local cj/gptel-autosave-enabled nil) - (setq-local cj/gptel-autosave-filepath "/tmp/foo.gptel") - (setq-local cj/gptel-autosave--timer :fake-timer) - (let ((cancelled nil)) - (cl-letf (((symbol-function 'cancel-timer) - (lambda (timer) (setq cancelled timer)))) - (cj/gptel--autosave-timer-callback buf)) - (should (eq cancelled :fake-timer)) - (should-not cj/gptel-autosave--timer))) - (when (buffer-live-p buf) - (kill-buffer buf))))) - -;; ------------------------------------------------------ save-conversation - -(ert-deftest test-ai-conversations-save-conversation-interactive-new-topic () - "Save-conversation writes file, enables autosave, and starts a timer." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((ai-buffer (generate-new-buffer "*AI-Assistant*"))) - (unwind-protect - (progn - (with-current-buffer ai-buffer - (setq-local gptel-mode t) - (insert "session content")) - (cl-letf (((symbol-function 'completing-read) - (lambda (&rest _) "Test Topic")) - ((symbol-function 'y-or-n-p) - (lambda (&rest _) nil)) - ((symbol-function 'run-with-timer) - (lambda (&rest _) :save-timer))) - (cj/gptel-save-conversation) - (let ((files (directory-files dir nil "test-topic_.*\\.gptel$"))) - (should files) - (should (= 1 (length files)))) - ;; Autosave state is set in the AI buffer - (with-current-buffer ai-buffer - (should cj/gptel-autosave-enabled) - (should (stringp cj/gptel-autosave-filepath)) - (should (eq cj/gptel-autosave--timer :save-timer))))) - (kill-buffer ai-buffer)))))) - -(ert-deftest test-ai-conversations-save-conversation-error-no-buffer () - "Save-conversation errors when *AI-Assistant* doesn't exist." - (when (get-buffer "*AI-Assistant*") - (kill-buffer "*AI-Assistant*")) - (should-error (cj/gptel-save-conversation))) - -;; ------------------------------------------------------ delete-conversation - -(ert-deftest test-ai-conversations-delete-conversation-interactive () - "Delete-conversation removes the chosen file after confirmation." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((file (test-ai-conversations--touch - dir "topic_20260101-100000.gptel"))) - (cl-letf (((symbol-function 'completing-read) - (lambda (_p cands &rest _) (caar cands))) - ((symbol-function 'y-or-n-p) - (lambda (&rest _) t))) - (cj/gptel-delete-conversation) - (should-not (file-exists-p file))))))) - -(ert-deftest test-ai-conversations-delete-conversation-cancelled () - "Delete-conversation preserves the file when the user declines." - (test-ai-conversations--with-temp-dir - (lambda (dir) - (let ((file (test-ai-conversations--touch - dir "topic_20260101-100000.gptel"))) - (cl-letf (((symbol-function 'completing-read) - (lambda (_p cands &rest _) (caar cands))) - ((symbol-function 'y-or-n-p) - (lambda (&rest _) nil))) - (cj/gptel-delete-conversation) - (should (file-exists-p file))))))) - -(ert-deftest test-ai-conversations-delete-conversation-error-empty-dir () - "Delete-conversation errors when no saved conversations exist." - (test-ai-conversations--with-temp-dir - (lambda (_dir) - (should-error (cj/gptel-delete-conversation))))) - -;; ------------------------------------------------------ install-once - -(ert-deftest test-ai-conversations-autosave-after-response-hook-not-duplicated () - "Loading ai-conversations twice does not duplicate the post-response hook." - (let ((gptel-post-response-functions - (list #'cj/gptel--autosave-after-response))) - ;; Re-run the install code - (unless (member #'cj/gptel--autosave-after-response gptel-post-response-functions) - (add-hook 'gptel-post-response-functions #'cj/gptel--autosave-after-response)) - (should (= 1 (cl-count #'cj/gptel--autosave-after-response - gptel-post-response-functions))))) - -;; --------------------------------------------- autosave-toggle / indicator - -(ert-deftest test-ai-conversations-autosave-toggle-enables-with-filepath () - "Toggle enables autosave when a filepath is set." - (with-temp-buffer - (setq-local gptel-mode t) - (setq-local cj/gptel-autosave-enabled nil) - (setq-local cj/gptel-autosave-filepath "/tmp/foo.gptel") - (cj/gptel-autosave-toggle) - (should cj/gptel-autosave-enabled))) - -(ert-deftest test-ai-conversations-autosave-toggle-disables () - "Toggle turns autosave off and cancels the periodic timer when already on." - (with-temp-buffer - (setq-local gptel-mode t) - (setq-local cj/gptel-autosave-enabled t) - (setq-local cj/gptel-autosave-filepath "/tmp/foo.gptel") - (setq-local cj/gptel-autosave--timer :fake-timer) - (let ((cancelled nil)) - (cl-letf (((symbol-function 'cancel-timer) - (lambda (timer) (setq cancelled timer)))) - (cj/gptel-autosave-toggle)) - (should-not cj/gptel-autosave-enabled) - (should (eq cancelled :fake-timer)) - (should-not cj/gptel-autosave--timer)))) - -(ert-deftest test-ai-conversations-autosave-toggle-prompts-when-no-filepath () - "Toggle prompts to save first when no filepath is configured." - (with-temp-buffer - (setq-local gptel-mode t) - (setq-local cj/gptel-autosave-enabled nil) - (setq-local cj/gptel-autosave-filepath nil) - (let ((prompted nil) - (save-called nil)) - (cl-letf (((symbol-function 'y-or-n-p) - (lambda (&rest _) (setq prompted t) nil)) - ((symbol-function 'cj/gptel-save-conversation) - (lambda () (setq save-called t)))) - (cj/gptel-autosave-toggle)) - (should prompted) - (should-not save-called) - (should-not cj/gptel-autosave-enabled)))) - -(ert-deftest test-ai-conversations-autosave-toggle-error-outside-gptel-mode () - "Toggle signals when called outside a gptel buffer." - (with-temp-buffer - (setq-local gptel-mode nil) - (should-error (cj/gptel-autosave-toggle)))) - -(ert-deftest test-ai-conversations-autosave-mode-line-format-evaluates () - "Mode-line format evaluates to \" [AS]\" only when autosave is enabled." - (with-temp-buffer - (setq-local cj/gptel-autosave-enabled t) - (should (equal (eval (cadr cj/gptel-autosave-mode-line-format)) - " [AS]"))) - (with-temp-buffer - (setq-local cj/gptel-autosave-enabled nil) - (should-not (eval (cadr cj/gptel-autosave-mode-line-format))))) - -(ert-deftest test-ai-conversations-install-mode-line-idempotent () - "Repeated installs do not duplicate the construct in mode-line-format." - (with-temp-buffer - (setq-local mode-line-format '("base")) - (cj/gptel--install-autosave-mode-line) - (cj/gptel--install-autosave-mode-line) - (cj/gptel--install-autosave-mode-line) - (should (= 1 (cl-count 'cj/gptel-autosave-mode-line-format mode-line-format))))) - -(provide 'test-ai-conversations) -;;; test-ai-conversations.el ends here diff --git a/tests/test-ai-mcp-helpers.el b/tests/test-ai-mcp-helpers.el deleted file mode 100644 index 5a995ff2d..000000000 --- a/tests/test-ai-mcp-helpers.el +++ /dev/null @@ -1,419 +0,0 @@ -;;; test-ai-mcp-helpers.el --- Tests for pure helpers in ai-mcp.el -*- lexical-binding: t; -*- - -;;; Commentary: -;; Normal / Boundary / Error tests for the side-effect-free helpers in -;; ai-mcp.el: secrets redaction, confirm-policy classifier, description -;; normalizer, Claude-config reader (mtime-cached), env / secret-args -;; resolution, server-alist builder. No real `~/.claude.json' reads; -;; fixtures are written to per-test temp files. No real subprocesses -;; or network calls. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ai-mcp) - -;; -------------------------------------------------------- fixtures - -(defconst test-ai-mcp--sentinel "REDACTED_TEST_SECRET" - "Sentinel that must never appear in any user-facing output.") - -(defconst test-ai-mcp--fixture-json - "{ - \"mcpServers\": { - \"drawio\": { - \"type\": \"stdio\", - \"command\": \"npx\", - \"args\": [\"-y\", \"@drawio/mcp\"] - }, - \"google-calendar\": { - \"type\": \"stdio\", - \"command\": \"npx\", - \"args\": [\"-y\", \"@cocal/google-calendar-mcp\"], - \"env\": { - \"GOOGLE_OAUTH_CREDENTIALS\": \"REDACTED_TEST_SECRET\" - } - }, - \"google-docs-personal\": { - \"type\": \"stdio\", - \"command\": \"npx\", - \"args\": [\"-y\", \"@a-bonus/google-docs-mcp\"], - \"env\": { - \"GOOGLE_CLIENT_ID\": \"REDACTED_TEST_SECRET\", - \"GOOGLE_CLIENT_SECRET\": \"REDACTED_TEST_SECRET\", - \"GOOGLE_MCP_PROFILE\": \"personal\" - } - }, - \"figma\": { - \"type\": \"stdio\", - \"command\": \"npx\", - \"args\": [\"-y\", \"figma-developer-mcp\", \"--figma-api-key=REDACTED_TEST_SECRET\", \"--stdio\"] - }, - \"linear\": { - \"type\": \"http\", - \"url\": \"https://mcp.linear.app/mcp\" - }, - \"slack-deepsat\": { - \"type\": \"sse\", - \"url\": \"http://127.0.0.1:13080/sse\" - } - } -}" - "Fixture matching the shape of a real ~/.claude.json mcpServers tree.") - -(defun test-ai-mcp--write-fixture (&optional content) - "Write CONTENT (defaults to the standard fixture) to a temp file. -Return the file path." - (let ((tmp (make-temp-file "test-ai-mcp-" nil ".json"))) - (with-temp-file tmp - (insert (or content test-ai-mcp--fixture-json))) - tmp)) - -(defmacro test-ai-mcp--with-fixture (var &rest body) - "Bind VAR to a fresh fixture file path and BODY-eval. Clean up after." - (declare (indent 1)) - `(let ((,var (test-ai-mcp--write-fixture)) - (cj/mcp--config-cache nil)) - (unwind-protect (progn ,@body) - (when (file-exists-p ,var) (delete-file ,var))))) - -;; -------------------------------------------------------- redact - -(ert-deftest test-ai-mcp-redact-token-eq-normal () - "Normal: --token=VALUE has the value replaced by ***." - (should (equal (cj/mcp--redact "--token=abc123") "--token=***"))) - -(ert-deftest test-ai-mcp-redact-token-spaced-boundary () - "Boundary: --token VALUE (space separator) is also redacted." - (should (equal (cj/mcp--redact "--token abc123") "--token ***"))) - -(ert-deftest test-ai-mcp-redact-secret-flag-normal () - "Normal: --secret=VALUE is redacted." - (should (equal (cj/mcp--redact "--secret=topsecret") "--secret=***"))) - -(ert-deftest test-ai-mcp-redact-password-flag-normal () - "Normal: --password=VALUE is redacted." - (should (equal (cj/mcp--redact "--password=hunter2") "--password=***"))) - -(ert-deftest test-ai-mcp-redact-figma-api-key-normal () - "Normal: --figma-api-key=VALUE is redacted (covers the figma case)." - (should (equal (cj/mcp--redact "--figma-api-key=figd_xyz") - "--figma-api-key=***"))) - -(ert-deftest test-ai-mcp-redact-authorization-header-normal () - "Normal: Authorization header value (scheme + token) is masked." - (should (equal (cj/mcp--redact "Authorization: Bearer ghp_xyz123") - "Authorization: ***"))) - -(ert-deftest test-ai-mcp-redact-url-token-normal () - "Normal: ?token=VALUE in a URL is masked." - (should (equal (cj/mcp--redact "https://api.example/v1?token=abc123&page=2") - "https://api.example/v1?token=***&page=2"))) - -(ert-deftest test-ai-mcp-redact-no-secrets-boundary () - "Boundary: a string with no known secrets is returned unchanged." - (should (equal (cj/mcp--redact "hello world, nothing secret here") - "hello world, nothing secret here"))) - -(ert-deftest test-ai-mcp-redact-empty-string-boundary () - "Boundary: empty string returns empty string." - (should (equal (cj/mcp--redact "") ""))) - -(ert-deftest test-ai-mcp-redact-multiple-secrets-boundary () - "Boundary: multiple secrets in one string are all redacted." - (let* ((input "--token=abc --secret=xyz --password=qwe") - (out (cj/mcp--redact input))) - (should (equal out "--token=*** --secret=*** --password=***")))) - -(ert-deftest test-ai-mcp-redact-nil-input-error () - "Error: nil input returns nil rather than signaling." - (should (null (cj/mcp--redact nil)))) - -(ert-deftest test-ai-mcp-redact-sentinel-never-leaks () - "Sentinel REDACTED_TEST_SECRET is replaced wherever it lives in a secret slot." - (dolist (input (list (format "--token=%s" test-ai-mcp--sentinel) - (format "--figma-api-key=%s" test-ai-mcp--sentinel) - (format "Authorization: Bearer %s" test-ai-mcp--sentinel) - (format "https://x/y?token=%s" test-ai-mcp--sentinel))) - (let ((out (cj/mcp--redact input))) - (should-not (string-match-p test-ai-mcp--sentinel out))))) - -;; -------------------------------------------------------- confirm-p - -(ert-deftest test-ai-mcp-confirm-p-write-pattern-normal () - "Normal: a write-prefixed tool name returns t." - (should (cj/mcp--confirm-p "mcp__linear__create_issue"))) - -(ert-deftest test-ai-mcp-confirm-p-read-pattern-normal () - "Normal: a read-prefixed tool name returns nil." - (should-not (cj/mcp--confirm-p "mcp__linear__list_issues"))) - -(ert-deftest test-ai-mcp-confirm-p-unknown-fails-closed-boundary () - "Boundary: a name matching neither read nor write defaults to t (fail closed)." - (should (cj/mcp--confirm-p "mcp__linear__frobnicate"))) - -(ert-deftest test-ai-mcp-confirm-p-explicit-remote-name-boundary () - "Boundary: REMOTE-NAME arg overrides the prefix-strip of GPTEL-NAME." - ;; The gptel-name claims read, but the explicit remote-name is a write - ;; verb, so confirm should still fire. - (should (cj/mcp--confirm-p "mcp__linear__list_issues" "create_issue"))) - -(ert-deftest test-ai-mcp-confirm-p-override-wins-boundary () - "Boundary: cj/mcp-tool-confirm-overrides wins over the classifier." - (let ((cj/mcp-tool-confirm-overrides - '(("mcp__linear__create_issue" . nil)))) - (should-not (cj/mcp--confirm-p "mcp__linear__create_issue")))) - -;; -------------------------------------------------------- normalize-description - -(ert-deftest test-ai-mcp-normalize-description-read-normal () - "Normal: a read tool gets the bare [SERVER] prefix." - (should (equal - (cj/mcp--normalize-description - "linear" - '(:name "list_issues" :description "List issues in a Linear team.")) - "[linear] List issues in a Linear team."))) - -(ert-deftest test-ai-mcp-normalize-description-write-normal () - "Normal: a write tool gets [SERVER WRITE] prefix." - (should (equal - (cj/mcp--normalize-description - "linear" - '(:name "create_issue" :description "Create a new Linear issue.")) - "[linear WRITE] Create a new Linear issue."))) - -(ert-deftest test-ai-mcp-normalize-description-unknown-boundary () - "Boundary: a tool matching neither classifier gets [SERVER ?] prefix." - (should (equal - (cj/mcp--normalize-description - "google-keep" - '(:name "frobnicate" :description "Do the frob thing.")) - "[google-keep ?] Do the frob thing."))) - -(ert-deftest test-ai-mcp-normalize-description-missing-upstream-boundary () - "Boundary: missing upstream description falls back to a placeholder." - (should (equal - (cj/mcp--normalize-description - "linear" - '(:name "list_issues")) - "[linear] (no description provided by server)"))) - -;; -------------------------------------------------------- read-claude-config - -(ert-deftest test-ai-mcp-read-claude-config-good-fixture-normal () - "Normal: parsing a well-formed fixture returns :ok t and the parsed data." - (test-ai-mcp--with-fixture path - (let ((result (cj/mcp--read-claude-config path))) - (should (plist-get result :ok)) - (should (plist-get (plist-get result :data) :mcpServers))))) - -(ert-deftest test-ai-mcp-read-claude-config-missing-file-error () - "Error: missing file returns :ok nil with :reason missing-file." - (let ((cj/mcp--config-cache nil) - (path "/nonexistent/path/never-will-exist.json")) - (let ((result (cj/mcp--read-claude-config path))) - (should-not (plist-get result :ok)) - (should (eq (plist-get result :reason) 'missing-file))))) - -(ert-deftest test-ai-mcp-read-claude-config-malformed-json-error () - "Error: malformed JSON returns :ok nil with :reason malformed-json and a message." - (let ((cj/mcp--config-cache nil) - (tmp (make-temp-file "test-ai-mcp-malformed-" nil ".json"))) - (unwind-protect - (progn - (with-temp-file tmp (insert "{ this is not valid json ::: ")) - (let ((result (cj/mcp--read-claude-config tmp))) - (should-not (plist-get result :ok)) - (should (eq (plist-get result :reason) 'malformed-json)) - (should (stringp (plist-get result :message))))) - (delete-file tmp)))) - -(ert-deftest test-ai-mcp-read-claude-config-empty-object-boundary () - "Boundary: an empty JSON object parses to ok with empty data plist." - (let ((cj/mcp--config-cache nil) - (tmp (make-temp-file "test-ai-mcp-empty-" nil ".json"))) - (unwind-protect - (progn - (with-temp-file tmp (insert "{}")) - (let ((result (cj/mcp--read-claude-config tmp))) - (should (plist-get result :ok)) - ;; :mcpServers is absent; plist-get returns nil. - (should-not (plist-get (plist-get result :data) :mcpServers)))) - (delete-file tmp)))) - -(ert-deftest test-ai-mcp-read-claude-config-cache-hit-boundary () - "Boundary: a second read with the same mtime reuses the cache. -We detect cache reuse by mutating the cached :data alist after the first -read and verifying the second read returns the mutated value." - (test-ai-mcp--with-fixture path - (let* ((first (cj/mcp--read-claude-config path)) - (cache cj/mcp--config-cache)) - (should (plist-get first :ok)) - ;; Mutate the cached :data so a cache-hit returns the marker. - (plist-put cache :data '(:sentinel cache-was-hit)) - (let ((second (cj/mcp--read-claude-config path))) - (should (equal (plist-get second :data) '(:sentinel cache-was-hit))))))) - -(ert-deftest test-ai-mcp-read-claude-config-cache-invalidate-on-mtime-boundary () - "Boundary: changing the file's mtime forces a reparse." - (test-ai-mcp--with-fixture path - (let* ((first (cj/mcp--read-claude-config path)) - (cache cj/mcp--config-cache)) - (should (plist-get first :ok)) - ;; Poison the cache, then bump mtime; the next read should reparse. - (plist-put cache :data '(:sentinel cache-was-hit)) - (set-file-times path (time-add (current-time) 2)) - ;; Update the cache var since set-file-times changed file mtime. - (setq cj/mcp--config-cache cache) - (let ((second (cj/mcp--read-claude-config path))) - ;; Real reparse should give us the real data, not the sentinel. - (should (plist-get (plist-get second :data) :mcpServers)))))) - -(ert-deftest test-ai-mcp-read-claude-config-missing-mcpservers-boundary () - "Boundary: a valid JSON without :mcpServers parses but the subtree is nil." - (let ((cj/mcp--config-cache nil) - (tmp (make-temp-file "test-ai-mcp-no-mcp-" nil ".json"))) - (unwind-protect - (progn - (with-temp-file tmp (insert "{\"other\": 1}")) - (let ((result (cj/mcp--read-claude-config tmp))) - (should (plist-get result :ok)) - (should-not (plist-get (plist-get result :data) :mcpServers)))) - (delete-file tmp)))) - -;; -------------------------------------------------------- get-env / get-secret-arg - -(ert-deftest test-ai-mcp-get-env-known-server-with-env-normal () - "Normal: env-bearing server returns its env plist." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (env (cj/mcp--get-env "google-calendar"))) - (should (equal (plist-get env :GOOGLE_OAUTH_CREDENTIALS) - test-ai-mcp--sentinel))))) - -(ert-deftest test-ai-mcp-get-env-known-server-without-env-boundary () - "Boundary: a server with no env subtree returns nil." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path)) - (should-not (cj/mcp--get-env "drawio"))))) - -(ert-deftest test-ai-mcp-get-env-unknown-server-error () - "Error: unknown server returns nil without signaling." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path)) - (should-not (cj/mcp--get-env "no-such-server"))))) - -(ert-deftest test-ai-mcp-get-secret-arg-figma-normal () - "Normal: figma's --figma-api-key= value is extracted from args." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (value (cj/mcp--get-secret-arg "figma" "--figma-api-key"))) - (should (equal value test-ai-mcp--sentinel))))) - -(ert-deftest test-ai-mcp-get-secret-arg-missing-flag-error () - "Error: a flag not in the server's args returns nil." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (value (cj/mcp--get-secret-arg "figma" "--no-such-flag"))) - (should (null value))))) - -;; -------------------------------------------------------- build-server-alist - -(ert-deftest test-ai-mcp-build-server-alist-all-enabled-normal () - "Normal: with default specs and all-enabled list, alist has all 9 entries." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (alist (cj/mcp--build-server-alist))) - (should (= (length alist) 9)) - ;; Every name appears. - (dolist (name '("linear" "notion" "figma" "slack-deepsat" "drawio" - "google-calendar" "google-docs-personal" - "google-docs-work" "google-keep")) - (should (assoc name alist)))))) - -(ert-deftest test-ai-mcp-build-server-alist-filter-by-enabled-boundary () - "Boundary: enabled subset of names produces a subset alist." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (alist (cj/mcp--build-server-alist - cj/mcp-server-specs - '("drawio" "linear")))) - (should (= (length alist) 2)) - (should (assoc "drawio" alist)) - (should (assoc "linear" alist)) - (should-not (assoc "figma" alist))))) - -(ert-deftest test-ai-mcp-build-server-alist-stdio-shape-normal () - "Normal: a stdio entry has :type, :command, :args (no :url)." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (alist (cj/mcp--build-server-alist - cj/mcp-server-specs '("drawio")))) - (let ((entry (cdr (assoc "drawio" alist)))) - (should (equal (plist-get entry :type) "stdio")) - (should (equal (plist-get entry :command) "npx")) - (should (listp (plist-get entry :args))) - (should-not (plist-get entry :url)))))) - -(ert-deftest test-ai-mcp-build-server-alist-http-shape-normal () - "Normal: an http entry has :type and :url (no :command)." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (alist (cj/mcp--build-server-alist - cj/mcp-server-specs '("linear")))) - (let ((entry (cdr (assoc "linear" alist)))) - (should (equal (plist-get entry :type) "http")) - (should (equal (plist-get entry :url) "https://mcp.linear.app/mcp")) - (should-not (plist-get entry :command)))))) - -(ert-deftest test-ai-mcp-build-server-alist-sse-shape-normal () - "Normal: an sse entry has :type and :url." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (alist (cj/mcp--build-server-alist - cj/mcp-server-specs '("slack-deepsat")))) - (let ((entry (cdr (assoc "slack-deepsat" alist)))) - (should (equal (plist-get entry :type) "sse")) - (should (equal (plist-get entry :url) - "http://127.0.0.1:13080/sse")))))) - -(ert-deftest test-ai-mcp-build-server-alist-env-merge-normal () - "Normal: env-bearing server has its env plist merged into the entry." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (alist (cj/mcp--build-server-alist - cj/mcp-server-specs '("google-calendar")))) - (let* ((entry (cdr (assoc "google-calendar" alist))) - (env (plist-get entry :env))) - (should env) - (should (equal (plist-get env :GOOGLE_OAUTH_CREDENTIALS) - test-ai-mcp--sentinel)))))) - -(ert-deftest test-ai-mcp-build-server-alist-secret-args-splice-normal () - "Normal: figma's --figma-api-key= is spliced into :args from Claude config." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (alist (cj/mcp--build-server-alist - cj/mcp-server-specs '("figma")))) - (let* ((entry (cdr (assoc "figma" alist))) - (args (plist-get entry :args)) - (api-arg (cl-find-if - (lambda (a) (string-prefix-p "--figma-api-key=" a)) - args))) - (should api-arg) - (should (equal api-arg (format "--figma-api-key=%s" - test-ai-mcp--sentinel))))))) - -(ert-deftest test-ai-mcp-build-server-alist-no-mutation-boundary () - "Boundary: building the alist does not mutate `cj/mcp-server-specs'." - (test-ai-mcp--with-fixture path - (let* ((cj/mcp-claude-config path) - (snapshot (copy-tree cj/mcp-server-specs))) - (cj/mcp--build-server-alist) - (should (equal cj/mcp-server-specs snapshot))))) - -(provide 'test-ai-mcp-helpers) -;;; test-ai-mcp-helpers.el ends here diff --git a/tests/test-ai-quick-ask.el b/tests/test-ai-quick-ask.el deleted file mode 100644 index 3e1f6460f..000000000 --- a/tests/test-ai-quick-ask.el +++ /dev/null @@ -1,149 +0,0 @@ -;;; test-ai-quick-ask.el --- Tests for ai-quick-ask -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the helpers and orchestration in ai-quick-ask.el. The -;; quick-ask buffer is exercised via `cl-letf' stubs on -;; `gptel-request' and friends so no network call ever happens. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) - -(require 'testutil-ai-config) -;; Stub gptel-request so cj/gptel-quick-ask doesn't try to hit the network. -(unless (fboundp 'gptel-request) - (defun gptel-request (&rest _args) nil)) - -(require 'ai-quick-ask) - -;; The quick-ask escalation reopens *AI-Assistant* through -;; cj/side-window-display, which reads the panel-width state ai-config owns. -;; ai-config isn't loaded here (it would pull in gptel), so declare those vars -;; globally to stand in for it -- a value-less defvar in the module is only -;; file-local to the byte-compiler, so the function reads them dynamically and -;; would otherwise hit void-variable. -(defvar cj/ai-assistant-window-width 0.4) -(defvar cj/--ai-assistant-width nil) - -;; ------------------------------ pure helpers - -(ert-deftest test-ai-quick-ask-initial-text-shape () - "Initial text is Q: <prompt> blank line then the response marker." - (should (equal (cj/gptel-quick--initial-text "hello?") - "Q: hello?\n\nA: "))) - -(ert-deftest test-ai-quick-ask-extract-response-normal () - "Extracts text after the response marker." - (should (equal (cj/gptel-quick--extract-response "Q: x\n\nA: hello world") - "hello world"))) - -(ert-deftest test-ai-quick-ask-extract-response-multiline () - "Multi-line response is returned in full." - (should (equal (cj/gptel-quick--extract-response - "Q: x\n\nA: first line\nsecond line\n") - "first line\nsecond line\n"))) - -(ert-deftest test-ai-quick-ask-extract-response-no-marker () - "Buffer without the marker returns nil." - (should-not (cj/gptel-quick--extract-response "no marker here"))) - -(ert-deftest test-ai-quick-ask-extract-response-empty () - "Empty buffer returns nil." - (should-not (cj/gptel-quick--extract-response ""))) - -(ert-deftest test-ai-quick-ask-seed-text-shape () - "Seed text has user heading, prompt, AI heading, response." - (let ((seed (cj/gptel-quick--seed-text "ask" "reply"))) - (should (string-match-p "^\\* .* \\[" seed)) - (should (string-match-p "ask" seed)) - (should (string-match-p "^\\* AI" seed)) - (should (string-match-p "reply" seed)))) - -(ert-deftest test-ai-quick-ask-seed-text-nil-response () - "Seed text with a nil response leaves an empty body for the AI side." - (let ((seed (cj/gptel-quick--seed-text "ask" nil))) - (should (string-match-p "^\\* AI" seed)))) - -;; ------------------------------ ask - -(ert-deftest test-ai-quick-ask-creates-buffer () - "Ask creates the *GPTel-Quick* buffer in cj/gptel-quick-mode." - (when (get-buffer cj/gptel-quick--buffer-name) - (kill-buffer cj/gptel-quick--buffer-name)) - (let (request-called) - (cl-letf (((symbol-function 'gptel-request) - (lambda (&rest _) (setq request-called t))) - ((symbol-function 'display-buffer) - (lambda (&rest _) nil))) - (cj/gptel-quick-ask "test prompt") - (let ((buf (get-buffer cj/gptel-quick--buffer-name))) - (should buf) - (with-current-buffer buf - (should (eq major-mode 'cj/gptel-quick-mode)) - (should (equal cj/gptel-quick--prompt "test prompt")) - (should (string-match-p "Q: test prompt" (buffer-string)))) - (kill-buffer buf)) - (should request-called)))) - -(ert-deftest test-ai-quick-ask-error-empty-prompt () - "Empty prompt signals." - (should-error (cj/gptel-quick-ask ""))) - -;; ------------------------------ dismiss - -(ert-deftest test-ai-quick-ask-dismiss-kills-buffer () - "Dismiss kills the *GPTel-Quick* buffer." - (let ((buf (get-buffer-create cj/gptel-quick--buffer-name))) - (should (buffer-live-p buf)) - (cj/gptel-quick-dismiss) - (should-not (buffer-live-p buf)))) - -(ert-deftest test-ai-quick-ask-dismiss-no-op-when-absent () - "Dismiss with no quick buffer is a no-op." - (when (get-buffer cj/gptel-quick--buffer-name) - (kill-buffer cj/gptel-quick--buffer-name)) - ;; Should not error - (cj/gptel-quick-dismiss)) - -;; ------------------------------ continue - -(ert-deftest test-ai-quick-ask-continue-seeds-ai-assistant () - "Continue seeds *AI-Assistant* with prompt + response and kills quick buffer." - (when (get-buffer cj/gptel-quick--buffer-name) - (kill-buffer cj/gptel-quick--buffer-name)) - (when (get-buffer "*AI-Assistant*") - (kill-buffer "*AI-Assistant*")) - (let ((display-called nil)) - (cl-letf (((symbol-function 'display-buffer-in-side-window) - (lambda (&rest _) (setq display-called t)))) - ;; Prepare a quick buffer with prompt + response - (with-current-buffer (get-buffer-create cj/gptel-quick--buffer-name) - (cj/gptel-quick-mode) - (let ((inhibit-read-only t)) - (insert (cj/gptel-quick--initial-text "what is X?")) - (insert "X is a thing.")) - (setq-local cj/gptel-quick--prompt "what is X?") - ;; Provide a stub *AI-Assistant* so continue doesn't try to call gptel. - (get-buffer-create "*AI-Assistant*") - (cj/gptel-quick-continue)) - (should display-called) - ;; *AI-Assistant* got the seed - (with-current-buffer "*AI-Assistant*" - (let ((body (buffer-string))) - (should (string-match-p "what is X?" body)) - (should (string-match-p "X is a thing\\." body)))) - ;; Quick buffer was dismissed - (should-not (get-buffer cj/gptel-quick--buffer-name)))) - (kill-buffer "*AI-Assistant*")) - -(ert-deftest test-ai-quick-ask-continue-error-outside-quick-buffer () - "Continue signals when called outside a quick-ask buffer." - (with-temp-buffer - (should-error (cj/gptel-quick-continue)))) - -(provide 'test-ai-quick-ask) -;;; test-ai-quick-ask.el ends here diff --git a/tests/test-ai-rewrite.el b/tests/test-ai-rewrite.el deleted file mode 100644 index ddb831339..000000000 --- a/tests/test-ai-rewrite.el +++ /dev/null @@ -1,159 +0,0 @@ -;;; test-ai-rewrite.el --- Tests for ai-rewrite.el -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the directive-picker wrappers around `gptel-rewrite'. -;; `gptel-rewrite' itself is stubbed so the tests verify what the -;; wrappers do (which directive body lands in the hook, which region -;; was captured) without touching the real rewrite UI. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) - -(require 'testutil-ai-config) - -;; Stub the gptel-rewrite surface so the wrapper can dispatch to it -;; without loading the real package. testutil-ai-config provides a -;; non-interactive stub of `gptel-rewrite'; we override it with an -;; interactive recorder that captures the hook-derived directive body -;; and the active region. -(defvar gptel-rewrite-directives-hook nil) -(defvar test-ai-rewrite--captured-directive nil - "Last system-message body produced by the hook during a stub rewrite.") -(defvar test-ai-rewrite--captured-region nil - "Cons (BEG . END) captured from `mark' and `point' at stub-rewrite time.") -(defun gptel-rewrite () - "Stub: capture the directive body and the active region." - (interactive) - (setq test-ai-rewrite--captured-directive - (run-hook-with-args-until-success 'gptel-rewrite-directives-hook)) - (setq test-ai-rewrite--captured-region - (cons (region-beginning) (region-end)))) - -(require 'ai-rewrite) - -;; ---------------------------- defcustom shape - -(ert-deftest test-ai-rewrite-directives-defcustom-has-named-entries () - "Default directives include the names called out in the spec." - (let ((names (mapcar #'car cj/gptel-rewrite-directives))) - (dolist (expected '("terse" "fix-grammar" "refactor-readability" - "add-docstring" "explain-as-comment" "shorten")) - (should (member expected names))))) - -(ert-deftest test-ai-rewrite-directives-bodies-are-strings () - "Every directive body is a non-empty string." - (dolist (entry cj/gptel-rewrite-directives) - (should (stringp (cdr entry))) - (should (> (length (cdr entry)) 0)))) - -;; ---------------------------- with-directive - -(ert-deftest test-ai-rewrite-with-directive-normal () - "Wrapper injects the directive body and runs gptel-rewrite on the region." - (with-temp-buffer - (insert "first body line\nsecond body line\n") - (let ((test-ai-rewrite--captured-directive nil) - (test-ai-rewrite--captured-region nil) - (cj/gptel-rewrite-directives - '(("test" . "BODY FOR TEST DIRECTIVE")))) - ;; Activate the region across both lines - (set-mark (point-min)) - (goto-char (point-max)) - (activate-mark) - (cj/gptel-rewrite-with-directive "test") - (should (equal test-ai-rewrite--captured-directive - "BODY FOR TEST DIRECTIVE")) - (should test-ai-rewrite--captured-region)))) - -(ert-deftest test-ai-rewrite-with-directive-error-no-region () - "No active region signals." - (with-temp-buffer - (insert "no region") - (deactivate-mark) - (should-error (call-interactively #'cj/gptel-rewrite-with-directive)))) - -(ert-deftest test-ai-rewrite-with-directive-error-unknown-directive () - "Unknown directive name signals." - (with-temp-buffer - (insert "body") - (set-mark (point-min)) - (goto-char (point-max)) - (activate-mark) - (let ((cj/gptel-rewrite-directives '(("known" . "x")))) - (should-error - (cj/gptel-rewrite--call-with-directive - "unknown" (point-min) (point-max)))))) - -(ert-deftest test-ai-rewrite-with-directive-records-last-state () - "Wrapper records the region and directive name for later redo." - (with-temp-buffer - (insert "abc\ndef\n") - (let ((cj/gptel-rewrite-directives - '(("first" . "FIRST BODY"))) - (test-ai-rewrite--captured-directive nil)) - (set-mark (point-min)) - (goto-char (point-max)) - (activate-mark) - (cj/gptel-rewrite-with-directive "first") - (should (equal cj/gptel-rewrite--last-directive "first")) - (should (consp cj/gptel-rewrite--last-region)) - (should (markerp (car cj/gptel-rewrite--last-region))) - (should (markerp (cdr cj/gptel-rewrite--last-region)))))) - -;; ---------------------------- redo - -(ert-deftest test-ai-rewrite-redo-normal () - "Redo replays the last region with a new directive." - (with-temp-buffer - (insert "line1\nline2\nline3\n") - (let* ((cj/gptel-rewrite-directives - '(("first" . "FIRST BODY") - ("second" . "SECOND BODY"))) - (test-ai-rewrite--captured-directive nil) - (test-ai-rewrite--captured-region nil)) - (set-mark (point-min)) - (goto-char (point-max)) - (activate-mark) - (cj/gptel-rewrite-with-directive "first") - (should (equal test-ai-rewrite--captured-directive "FIRST BODY")) - (let ((first-region test-ai-rewrite--captured-region)) - (setq test-ai-rewrite--captured-directive nil) - (setq test-ai-rewrite--captured-region nil) - (cl-letf (((symbol-function 'completing-read) - (lambda (_p choices &rest _) (car choices)))) - (cj/gptel-rewrite-redo-with-different-directive)) - (should (equal test-ai-rewrite--captured-directive "SECOND BODY")) - (should (equal test-ai-rewrite--captured-region first-region)))))) - -(ert-deftest test-ai-rewrite-redo-error-no-previous () - "Redo without prior rewrite signals." - (with-temp-buffer - (setq-local cj/gptel-rewrite--last-region nil) - (should-error (cj/gptel-rewrite-redo-with-different-directive)))) - -(ert-deftest test-ai-rewrite-redo-excludes-current-directive () - "Redo's completing-read prompt offers every directive except the last." - (with-temp-buffer - (insert "body") - (let ((cj/gptel-rewrite-directives - '(("a" . "A") ("b" . "B") ("c" . "C"))) - (offered nil)) - (set-mark (point-min)) - (goto-char (point-max)) - (activate-mark) - (cj/gptel-rewrite-with-directive "b") - (cl-letf (((symbol-function 'completing-read) - (lambda (_p choices &rest _) - (setq offered choices) - (car choices)))) - (cj/gptel-rewrite-redo-with-different-directive)) - (should (equal (sort (copy-sequence offered) #'string<) - '("a" "c")))))) - -(provide 'test-ai-rewrite) -;;; test-ai-rewrite.el ends here diff --git a/tests/test-ai-term--active-agent-dirs.el b/tests/test-ai-term--active-agent-dirs.el new file mode 100644 index 000000000..86e557b42 --- /dev/null +++ b/tests/test-ai-term--active-agent-dirs.el @@ -0,0 +1,50 @@ +;;; test-ai-term--active-agent-dirs.el --- Tests for cj/--ai-term-active-agent-dirs -*- lexical-binding: t; -*- + +;;; Commentary: +;; The queue `cj/ai-term-next' steps through: project dirs with an active +;; agent, which is either a live agent buffer (attached) or a live tmux session +;; with no Emacs buffer (detached). Folding detached sessions in is what lets +;; the step key reach and attach a session that isn't currently on screen. +;; 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--active-agent-dirs-includes-attached-and-detached () + "Normal: dirs with a live buffer OR a live session are active and sorted by +name; dirs with neither are excluded." + (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); beta/delta neither. + (should (equal '("/p/alpha" "/p/gamma") (cj/--ai-term-active-agent-dirs)))) + (kill-buffer buf)))) + +(ert-deftest test-ai-term--active-agent-dirs-detached-only () + "Normal: a dir with only a live session (no buffer) is included -- the detached case." + (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 (equal '("/p/solo") (cj/--ai-term-active-agent-dirs))))) + +(ert-deftest test-ai-term--active-agent-dirs-empty-when-none-active () + "Boundary: no live buffers and no sessions -> an empty queue." + (cl-letf (((symbol-function 'cj/--ai-term-candidates) (lambda (&rest _) '("/p/a" "/p/b"))) + ((symbol-function 'cj/--ai-term-agent-buffers) (lambda (&rest _) nil)) + ((symbol-function 'cj/--ai-term-live-tmux-sessions) (lambda (&rest _) nil))) + (should (null (cj/--ai-term-active-agent-dirs))))) + +(provide 'test-ai-term--active-agent-dirs) +;;; test-ai-term--active-agent-dirs.el ends here diff --git a/tests/test-ai-term--capture-state.el b/tests/test-ai-term--capture-state.el index 543f83ad7..aa7421350 100644 --- a/tests/test-ai-term--capture-state.el +++ b/tests/test-ai-term--capture-state.el @@ -27,7 +27,9 @@ (should (= cj/--ai-term-last-size (window-body-width right)))))) (ert-deftest test-ai-term--capture-state-below-split-sets-direction () - "Normal: below-split window -> direction=below, integer body-lines matching window." + "Normal: below-split window -> direction=below, integer total-lines matching window. +The vertical axis captures total-height (not body-height) so the toggle +round-trip is immune to the mode line's pixel height." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below)) @@ -36,7 +38,7 @@ (cj/--ai-term-capture-state below) (should (eq cj/--ai-term-last-direction 'below)) (should (integerp cj/--ai-term-last-size)) - (should (= cj/--ai-term-last-size (window-body-height below)))))) + (should (= cj/--ai-term-last-size (window-total-height below)))))) (ert-deftest test-ai-term--capture-state-noop-on-dead-window () "Boundary: nil window -> state remains unchanged." diff --git a/tests/test-ai-term--collapse-split.el b/tests/test-ai-term--collapse-split.el index d7b4ee17f..a09af5598 100644 --- a/tests/test-ai-term--collapse-split.el +++ b/tests/test-ai-term--collapse-split.el @@ -59,7 +59,12 @@ different agent (stale quit-restore after slot reuse)." (agent-a (get-buffer-create "agent [collapse-a]")) (agent-b (get-buffer-create "agent [collapse-b]")) (agent-c (get-buffer-create "agent [collapse-c]")) - (cj/--ai-term-last-was-bury nil)) + (cj/--ai-term-last-was-bury nil) + ;; Isolate the layout-capture globals cj/ai-term writes on toggle-off, + ;; so this test doesn't leak last-direction/last-size into others -- the + ;; display-rule test splits via display-saved, which reads them. + (cj/--ai-term-last-direction nil) + (cj/--ai-term-last-size nil)) (unwind-protect (save-window-excursion (delete-other-windows) @@ -89,7 +94,12 @@ to a NON-agent buffer (the working file), never another agent. Before the fix, (let ((work (get-buffer-create "*test-collapse-sw-work*")) (agent-a (get-buffer-create "agent [collapse-sw-a]")) (agent-b (get-buffer-create "agent [collapse-sw-b]")) - (cj/--ai-term-last-was-bury nil)) + (cj/--ai-term-last-was-bury nil) + ;; Isolate the layout-capture globals cj/ai-term writes on toggle-off, + ;; so this test doesn't leak last-direction/last-size into others -- the + ;; display-rule test splits via display-saved, which reads them. + (cj/--ai-term-last-direction nil) + (cj/--ai-term-last-size nil)) (unwind-protect (save-window-excursion (delete-other-windows) diff --git a/tests/test-ai-term--default-geometry.el b/tests/test-ai-term--default-geometry.el index 833f2ef4c..1180c1979 100644 --- a/tests/test-ai-term--default-geometry.el +++ b/tests/test-ai-term--default-geometry.el @@ -1,15 +1,20 @@ ;;; test-ai-term--default-geometry.el --- Tests for host-aware display defaults -*- lexical-binding: t; -*- ;;; Commentary: -;; ai-term's default display geometry is host-aware: a laptop opens the -;; agent from the bottom (75% height), a desktop opens it from the right -;; (50% width). `cj/--ai-term-default-direction' and -;; `cj/--ai-term-default-size' encapsulate the `env-laptop-p' branch; -;; they feed the default fallbacks in `cj/--ai-term-capture-state' and -;; `cj/--ai-term-display-saved'. +;; ai-term's default display geometry is chosen from the frame's column +;; width: the agent docks from the right (a width fraction) only when a +;; side-by-side split would leave both panes at least +;; `cj/window-dock-min-columns' wide, otherwise from the bottom (a height +;; fraction). `cj/--ai-term-default-direction' reads the frame width and +;; delegates the decision to `cj/preferred-dock-direction' (tested in +;; test-cj-window-geometry-lib.el); `cj/--ai-term-default-size' pairs the +;; size fraction with that direction. They feed the default fallbacks in +;; `cj/--ai-term-capture-state' and `cj/--ai-term-display-saved'. ;; -;; `env-laptop-p' is stubbed per-test so the assertions are deterministic -;; regardless of the host the suite runs on. +;; The direction is tested by stubbing `cj/preferred-dock-direction' (an +;; ordinary defun -- safe to `cl-letf', unlike the frame-* subrs, which +;; would trip the native-comp trampoline trap); the size helper is tested +;; by stubbing the direction defun. ;;; Code: @@ -19,37 +24,48 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'ai-term) -(ert-deftest test-ai-term--default-direction-laptop () - "Normal: on a laptop the default direction is `below'." - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) - (should (eq (cj/--ai-term-default-direction) 'below)))) +(ert-deftest test-ai-term--default-direction-delegates-to-dock-rule () + "Normal: default-direction passes the desktop-width fraction to the dock rule +and returns its verdict." + (let ((cj/ai-term-desktop-width 0.5) + captured) + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (cols frac &rest _) + (setq captured (list cols frac)) + 'below))) + (should (eq (cj/--ai-term-default-direction) 'below)) + ;; the fraction passed is the agent's desktop-width + (should (= (nth 1 captured) 0.5)) + ;; the first argument is a column count (the frame width) + (should (integerp (nth 0 captured)))))) -(ert-deftest test-ai-term--default-direction-desktop () - "Normal: on a desktop the default direction is `right'." - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) +(ert-deftest test-ai-term--default-direction-returns-right-when-rule-says () + "Normal: when the dock rule returns `right', so does default-direction." + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (&rest _) 'right))) (should (eq (cj/--ai-term-default-direction) 'right)))) -(ert-deftest test-ai-term--default-size-laptop () - "Normal: on a laptop the default size is `cj/ai-term-laptop-height'." +(ert-deftest test-ai-term--default-size-pairs-width-with-right () + "Normal: when the direction is `right' the size is the width fraction." (let ((cj/ai-term-laptop-height 0.75) (cj/ai-term-desktop-width 0.5)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) - (should (= (cj/--ai-term-default-size) 0.75))))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) + (should (= (cj/--ai-term-default-size) 0.5))))) -(ert-deftest test-ai-term--default-size-desktop () - "Normal: on a desktop the default size is `cj/ai-term-desktop-width'." +(ert-deftest test-ai-term--default-size-pairs-height-with-below () + "Normal: when the direction is `below' the size is the height fraction." (let ((cj/ai-term-laptop-height 0.75) (cj/ai-term-desktop-width 0.5)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) - (should (= (cj/--ai-term-default-size) 0.5))))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) + (should (= (cj/--ai-term-default-size) 0.75))))) (ert-deftest test-ai-term--default-size-respects-custom-values () "Boundary: the helper returns the customized values, not the literals." (let ((cj/ai-term-laptop-height 0.6) (cj/ai-term-desktop-width 0.33)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) (should (= (cj/--ai-term-default-size) 0.6))) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (should (= (cj/--ai-term-default-size) 0.33))))) (provide 'test-ai-term--default-geometry) diff --git a/tests/test-ai-term--display-rule.el b/tests/test-ai-term--display-rule.el index 906a47680..4a148a5c0 100644 --- a/tests/test-ai-term--display-rule.el +++ b/tests/test-ai-term--display-rule.el @@ -38,7 +38,7 @@ desktop branch; on a laptop the agent would land below instead." (let ((name "agent [display-rule-test]")) (test-ai-term--cleanup name) (unwind-protect - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (test-ai-term--with-clean-frame (let* ((buf (get-buffer-create name)) (win (display-buffer buf))) diff --git a/tests/test-ai-term--display-saved.el b/tests/test-ai-term--display-saved.el index 8b689aa6b..51c22fde9 100644 --- a/tests/test-ai-term--display-saved.el +++ b/tests/test-ai-term--display-saved.el @@ -32,13 +32,12 @@ "Normal: nil state on a desktop -> rightmost, size=cj/ai-term-desktop-width. The cardinal `right' default maps to the frame-edge variant `rightmost' so agent lands at the frame's right edge regardless of -which window is selected. `env-laptop-p' is stubbed nil to pin the -desktop branch." +which window is selected. The default direction is stubbed `right'." (let (received-buf received-alist (cj/--ai-term-last-direction nil) (cj/--ai-term-last-size nil) (cj/ai-term-desktop-width 0.5)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil)) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right)) ((symbol-function 'display-buffer-in-direction) (lambda (b a) (setq received-buf b received-alist a) @@ -49,16 +48,16 @@ desktop branch." (should (= (cdr (assq 'window-width received-alist)) 0.5)) (should (eq (cdr (assq 'inhibit-same-window received-alist)) t)))) -(ert-deftest test-ai-term--display-saved-uses-laptop-defaults-when-state-nil () - "Normal: nil state on a laptop -> bottom, size=cj/ai-term-laptop-height. +(ert-deftest test-ai-term--display-saved-uses-below-default-when-state-nil () + "Normal: nil state with a `below' default -> bottom, size=cj/ai-term-laptop-height. The cardinal `below' default maps to the frame-edge variant `bottom' -and the size lands on the `window-height' axis. `env-laptop-p' is -stubbed t to pin the laptop branch." +and the size lands on the `window-height' axis. The default direction +is stubbed `below' (the size helper follows it)." (let (received-alist (cj/--ai-term-last-direction nil) (cj/--ai-term-last-size nil) (cj/ai-term-laptop-height 0.75)) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t)) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below)) ((symbol-function 'display-buffer-in-direction) (lambda (_b a) (setq received-alist a) 'fake-window))) (cj/--ai-term-display-saved 'fake-buf '((inhibit-same-window . t)))) diff --git a/tests/test-ai-term--f9-in-term.el b/tests/test-ai-term--f9-in-term.el deleted file mode 100644 index dad11ffc0..000000000 --- a/tests/test-ai-term--f9-in-term.el +++ /dev/null @@ -1,56 +0,0 @@ -;;; test-ai-term--f9-in-term.el --- F9 reaches Emacs from inside an agent buffer -*- lexical-binding: t; -*- - -;;; Commentary: -;; ghostel's semi-char mode forwards keys not in `ghostel-keymap-exceptions' to -;; the terminal program, so a plain <f9> typed while point is in an agent -;; buffer would be sent to the program instead of toggling the agent -- exactly -;; the case when the agent buffer fills the frame. `ai-term.el' re-binds the F9 -;; family in `ghostel-mode-map'. These tests require ghostel (which defines -;; `ghostel-mode-map' and lets ai-term's `with-eval-after-load' fire) BEFORE -;; ai-term, then confirm the bindings landed (and the global ones are intact). -;; `(require 'ghostel)' does not load the native module, so this stays light. - -;;; Code: - -(require 'ert) -(require 'package) - -(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) -(package-initialize) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ghostel) -(require 'ai-term) - -(ert-deftest test-ai-term-f9-bound-in-ghostel-mode-map () - "Normal: <f9> in `ghostel-mode-map' runs the agent toggle." - (should (eq (keymap-lookup ghostel-mode-map "<f9>") #'cj/ai-term))) - -(ert-deftest test-ai-term-f9-family-bound-in-ghostel-mode-map () - "Normal: the C-/M-/C-S- F9 variants are bound in `ghostel-mode-map' too. -`M-<f9>' and `C-S-<f9>' both close an agent via `cj/ai-term-close'." - (should (eq (keymap-lookup ghostel-mode-map "C-<f9>") #'cj/ai-term-pick-project)) - (should (eq (keymap-lookup ghostel-mode-map "M-<f9>") #'cj/ai-term-close)) - (should (eq (keymap-lookup ghostel-mode-map "C-S-<f9>") #'cj/ai-term-close))) - -(ert-deftest test-ai-term-f9-still-bound-globally () - "Normal: the global F9 family bindings are intact. -`<f9>' toggles the ai-term agent window; `C-<f9>' picks a project -agent; `M-<f9>' and `C-S-<f9>' close an agent via `cj/ai-term-close'." - (should (eq (lookup-key (current-global-map) (kbd "<f9>")) #'cj/ai-term)) - (should (eq (lookup-key (current-global-map) (kbd "C-<f9>")) #'cj/ai-term-pick-project)) - (should (eq (lookup-key (current-global-map) (kbd "M-<f9>")) #'cj/ai-term-close)) - (should (eq (lookup-key (current-global-map) (kbd "C-S-<f9>")) #'cj/ai-term-close))) - -(ert-deftest test-ai-term-f9-family-in-keymap-exceptions () - "Regression: the F9 family is in `ghostel-keymap-exceptions' so semi-char -mode lets it reach Emacs instead of forwarding it to the terminal program. -Binding in `ghostel-mode-map' alone is not enough -- the semi-char map outranks -it and forwards any key not in the exceptions to the pty." - (dolist (key '("<f9>" "C-<f9>" "M-<f9>" "C-S-<f9>")) - (should (member key ghostel-keymap-exceptions))) - ;; The rebuilt semi-char map must no longer forward <f9> to the pty. - (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "<f9>") - 'ghostel--send-event))) - -(provide 'test-ai-term--f9-in-term) -;;; test-ai-term--f9-in-term.el ends here diff --git a/tests/test-ai-term--keybindings.el b/tests/test-ai-term--keybindings.el new file mode 100644 index 000000000..6f7f53a5e --- /dev/null +++ b/tests/test-ai-term--keybindings.el @@ -0,0 +1,53 @@ +;;; test-ai-term--keybindings.el --- ai-term keybinding placement -*- lexical-binding: t; -*- + +;;; Commentary: +;; ai-term lives under the C-; a prefix (vacated when gptel was archived), with +;; the frequent "swap to the next agent" also on M-SPC for a fast chord. M-SPC +;; must reach Emacs from inside an agent buffer, so it is bound in +;; `eat-semi-char-mode-map' (EAT forwards unbound keys to the pty otherwise). +;; C-; is already bound there via eat-config, so the C-; a family resolves +;; through the global prefix. These tests require eat (so ai-term's +;; `with-eval-after-load' fires) before ai-term, then confirm the bindings +;; landed and the old F9 family is gone. + +;;; Code: + +(require 'ert) +(require 'package) + +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'eat) +(require 'ai-term) + +(ert-deftest test-ai-term-keymap-leaf-bindings () + "Normal: the ai-term keymap binds toggle/select/next/kill on a/s/n/k." + (should (eq (keymap-lookup cj/ai-term-keymap "a") #'cj/ai-term)) + (should (eq (keymap-lookup cj/ai-term-keymap "s") #'cj/ai-term-pick-project)) + (should (eq (keymap-lookup cj/ai-term-keymap "n") #'cj/ai-term-next)) + (should (eq (keymap-lookup cj/ai-term-keymap "k") #'cj/ai-term-close))) + +(ert-deftest test-ai-term-keymap-registered-under-custom-prefix () + "Normal: the ai-term keymap is registered under C-; a." + (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))) + +(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))) + +(ert-deftest test-ai-term-f9-family-removed-globally () + "Regression: the old F9 family no longer binds the ai-term commands globally." + (should-not (eq (lookup-key (current-global-map) (kbd "<f9>")) #'cj/ai-term)) + (should-not (eq (lookup-key (current-global-map) (kbd "C-<f9>")) #'cj/ai-term-pick-project)) + (should-not (eq (lookup-key (current-global-map) (kbd "s-<f9>")) #'cj/ai-term-next)) + (should-not (eq (lookup-key (current-global-map) (kbd "M-<f9>")) #'cj/ai-term-close))) + +(provide 'test-ai-term--keybindings) +;;; test-ai-term--keybindings.el ends here diff --git a/tests/test-ai-term--live-count.el b/tests/test-ai-term--live-count.el new file mode 100644 index 000000000..1432599cc --- /dev/null +++ b/tests/test-ai-term--live-count.el @@ -0,0 +1,60 @@ +;;; test-ai-term--live-count.el --- Tests for cj/ai-term-live-count -*- lexical-binding: t; -*- + +;;; Commentary: +;; The shutdown safety gate: the integer count of live AI-term (aiv-*) tmux +;; sessions, read by the rulesets wrap-it-up workflow via emacsclient -e. No +;; server / no sessions is 0, not an error. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(defmacro test-ai-term-live-count--with-tmux (exit-code output &rest body) + "Run BODY with `process-file' mocked to a tmux list-sessions response. +EXIT-CODE is returned (or the symbol `error' to signal); OUTPUT is written to +the stdout destination buffer." + (declare (indent 2)) + `(cl-letf (((symbol-function 'process-file) + (lambda (_program _infile destination _display &rest _args) + (when (eq ,exit-code 'error) (error "tmux: command not found")) + (let ((buffer (cond ((eq destination t) (current-buffer)) + ((bufferp destination) destination) + ((consp destination) + (and (eq (car destination) t) (current-buffer)))))) + (when (bufferp buffer) + (with-current-buffer buffer (insert ,output)))) + ,exit-code))) + (let ((cj/ai-term-tmux-session-prefix "aiv-")) + ,@body))) + +(ert-deftest test-ai-term-live-count-counts-matching-sessions () + "Normal: two aiv-* sessions among others count as 2." + (test-ai-term-live-count--with-tmux 0 "aiv-foo\nrandom\naiv-bar\n" + (should (= (cj/ai-term-live-count) 2)))) + +(ert-deftest test-ai-term-live-count-single-session () + "Boundary: a sole aiv-* session counts as 1." + (test-ai-term-live-count--with-tmux 0 "aiv-only\nother\n" + (should (= (cj/ai-term-live-count) 1)))) + +(ert-deftest test-ai-term-live-count-no-matching-sessions () + "Boundary: a running server with no aiv-* sessions is 0." + (test-ai-term-live-count--with-tmux 0 "other-a\nother-b\n" + (should (= (cj/ai-term-live-count) 0)))) + +(ert-deftest test-ai-term-live-count-no-server () + "Error: tmux exits non-zero (no server) -> 0, not a signal." + (test-ai-term-live-count--with-tmux 1 "no server running\n" + (should (= (cj/ai-term-live-count) 0)))) + +(ert-deftest test-ai-term-live-count-tmux-missing () + "Error: tmux not installed -> 0." + (test-ai-term-live-count--with-tmux 'error "" + (should (= (cj/ai-term-live-count) 0)))) + +(provide 'test-ai-term--live-count) +;;; test-ai-term--live-count.el ends here diff --git a/tests/test-ai-term--next-agent-dir.el b/tests/test-ai-term--next-agent-dir.el new file mode 100644 index 000000000..b5cf1cdf5 --- /dev/null +++ b/tests/test-ai-term--next-agent-dir.el @@ -0,0 +1,48 @@ +;;; test-ai-term--next-agent-dir.el --- Tests for cj/--ai-term-next-agent-dir -*- lexical-binding: t; -*- + +;;; Commentary: +;; The pure decision helper behind `cj/ai-term-next'. Given the current +;; active-agent project dir and the ordered list of active-agent dirs, it +;; returns the next dir in the queue, wrapping after the last. A nil or +;; non-member CURRENT returns the first; an empty list returns nil. Dirs are +;; matched with `member' (string equality). No side effects -- list logic only. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(defconst test-ai-term--dirs '("/p/a" "/p/b" "/p/c")) + +(ert-deftest test-ai-term--next-agent-dir-advances-from-first () + "Normal: current is the first element -> returns the second." + (should (equal "/p/b" (cj/--ai-term-next-agent-dir "/p/a" test-ai-term--dirs)))) + +(ert-deftest test-ai-term--next-agent-dir-advances-from-middle () + "Normal: current in the middle -> returns the following element." + (should (equal "/p/c" (cj/--ai-term-next-agent-dir "/p/b" test-ai-term--dirs)))) + +(ert-deftest test-ai-term--next-agent-dir-wraps-after-last () + "Boundary: current is the last element -> wraps to the first." + (should (equal "/p/a" (cj/--ai-term-next-agent-dir "/p/c" test-ai-term--dirs)))) + +(ert-deftest test-ai-term--next-agent-dir-single-element-returns-itself () + "Boundary: a one-agent queue wraps current back to itself." + (should (equal "/p/a" (cj/--ai-term-next-agent-dir "/p/a" '("/p/a"))))) + +(ert-deftest test-ai-term--next-agent-dir-nil-current-returns-first () + "Boundary: nil current (no agent displayed) -> returns the first." + (should (equal "/p/a" (cj/--ai-term-next-agent-dir nil '("/p/a" "/p/b"))))) + +(ert-deftest test-ai-term--next-agent-dir-non-member-current-returns-first () + "Error: current not in the queue -> returns the first rather than nil." + (should (equal "/p/a" (cj/--ai-term-next-agent-dir "/p/stray" '("/p/a" "/p/b"))))) + +(ert-deftest test-ai-term--next-agent-dir-empty-queue-returns-nil () + "Boundary: an empty queue returns nil (nothing to switch to)." + (should (null (cj/--ai-term-next-agent-dir nil '())))) + +(provide 'test-ai-term--next-agent-dir) +;;; test-ai-term--next-agent-dir.el ends here diff --git a/tests/test-ai-term--next-no-agents.el b/tests/test-ai-term--next-no-agents.el new file mode 100644 index 000000000..59132df8e --- /dev/null +++ b/tests/test-ai-term--next-no-agents.el @@ -0,0 +1,34 @@ +;;; test-ai-term--next-no-agents.el --- cj/ai-term-next no-agents fallback -*- lexical-binding: t; -*- + +;;; Commentary: +;; When no agent buffers are open, `cj/ai-term-next' (bound to M-SPC) launches +;; the project picker (`cj/ai-term-pick-project') to start the first agent, +;; instead of signalling a `user-error'. The swap key thus doubles as a +;; "start an agent" key when there is nothing to swap to. + +;;; 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-next-no-agents-launches-picker () + "Error: no agents open -> launches the picker instead of erroring." + (let ((picked 0)) + (cl-letf (((symbol-function 'cj/--ai-term-active-agent-dirs) (lambda (&rest _) nil)) + ((symbol-function 'cj/--ai-term-displayed-agent-window) (lambda (&rest _) nil)) + ((symbol-function 'cj/ai-term-pick-project) (lambda (&rest _) (setq picked (1+ picked))))) + (cj/ai-term-next) + (should (= picked 1))))) + +(ert-deftest test-ai-term-next-no-agents-does-not-signal () + "Error: no agents open -> returns normally, no user-error raised." + (cl-letf (((symbol-function 'cj/--ai-term-active-agent-dirs) (lambda (&rest _) nil)) + ((symbol-function 'cj/--ai-term-displayed-agent-window) (lambda (&rest _) nil)) + ((symbol-function 'cj/ai-term-pick-project) (lambda (&rest _) nil))) + (should (progn (cj/ai-term-next) t)))) + +(provide 'test-ai-term--next-no-agents) +;;; test-ai-term--next-no-agents.el ends here diff --git a/tests/test-ai-term--quit.el b/tests/test-ai-term--quit.el new file mode 100644 index 000000000..55ace81db --- /dev/null +++ b/tests/test-ai-term--quit.el @@ -0,0 +1,65 @@ +;;; test-ai-term--quit.el --- Tests for cj/ai-term-quit -*- lexical-binding: t; -*- + +;;; Commentary: +;; Headless teardown of a project's AI-term: kill the aiv-<name> tmux session, +;; then the agent buffer. Driven by the rulesets Stop hook via emacsclient -e, +;; keyed by project basename. Must be idempotent (a no-op when already gone). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(defmacro test-ai-term-quit--with-tmux (calls-var &rest body) + "Run BODY with `process-file' mocked to record arg lists into CALLS-VAR (0 exit)." + (declare (indent 1)) + `(cl-letf (((symbol-function 'process-file) + (lambda (_program _infile _destination _display &rest args) + (push args ,calls-var) 0))) + ,@body)) + +(ert-deftest test-ai-term-quit-kills-session-and-buffer () + "Normal: quit kills the project's aiv- session and its agent buffer." + (let ((buf (get-buffer-create "agent [myproj]")) + (calls nil)) + (unwind-protect + (test-ai-term-quit--with-tmux calls + (cj/ai-term-quit "myproj") + (should (member '("kill-session" "-t" "aiv-myproj") calls)) + (should-not (buffer-live-p buf))) + (when (buffer-live-p buf) (kill-buffer buf))))) + +(ert-deftest test-ai-term-quit-sanitizes-dotted-basename () + "Boundary: a dotted basename maps to the sanitized session tmux really uses." + (let ((buf (get-buffer-create "agent [.emacs.d]")) + (calls nil)) + (unwind-protect + (test-ai-term-quit--with-tmux calls + (cj/ai-term-quit ".emacs.d") + (should (member '("kill-session" "-t" "aiv-_emacs_d") 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)) + (test-ai-term-quit--with-tmux calls + ;; No buffer named "agent [ghost]" exists; session kill is a no-op in tmux. + (should (stringp (cj/ai-term-quit "ghost"))) + (should (member '("kill-session" "-t" "aiv-ghost") calls))))) + +(ert-deftest test-ai-term-quit-leaves-non-agent-buffers () + "Error: a same-named-but-non-agent buffer is never killed (prefix guard)." + (let ((buf (get-buffer-create "notes-myproj")) + (calls nil)) + (unwind-protect + (test-ai-term-quit--with-tmux calls + (cj/ai-term-quit "myproj") + (should (buffer-live-p buf))) + (when (buffer-live-p buf) (kill-buffer buf))))) + +(provide 'test-ai-term--quit) +;;; test-ai-term--quit.el ends here diff --git a/tests/test-ai-term--reuse-edge-window.el b/tests/test-ai-term--reuse-edge-window.el index c41aab73a..a9a0529e8 100644 --- a/tests/test-ai-term--reuse-edge-window.el +++ b/tests/test-ai-term--reuse-edge-window.el @@ -45,7 +45,7 @@ right half: the frame stays at two windows [left | agent]." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((left-buf (get-buffer-create left-name)) (right-buf (get-buffer-create right-name)) (agent-buf (get-buffer-create agent-name))) @@ -77,7 +77,7 @@ bottom half: the frame stays at two windows." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () t))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) (let ((top-buf (get-buffer-create top-name)) (bottom-buf (get-buffer-create bottom-name)) (agent-buf (get-buffer-create agent-name))) @@ -107,7 +107,7 @@ the frame goes from one window to two with the agent present." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((sole-buf (get-buffer-create sole-name)) (agent-buf (get-buffer-create agent-name))) (set-window-buffer (selected-window) sole-buf) @@ -133,7 +133,7 @@ ends up displayed." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((top-buf (get-buffer-create top-name)) (bottom-buf (get-buffer-create bottom-name)) (agent-buf (get-buffer-create agent-name))) @@ -165,7 +165,7 @@ window rather than restoring the displaced buffer into a kept slot." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((left-buf (get-buffer-create left-name)) (right-buf (get-buffer-create right-name)) (agent-buf (get-buffer-create agent-name))) @@ -202,7 +202,7 @@ preserved across the toggle (respect-split-width)." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((left-buf (get-buffer-create left-name)) (right-buf (get-buffer-create right-name)) (agent-buf (get-buffer-create agent-name)) @@ -246,7 +246,7 @@ most-recent agent, which would now be the other one." (unwind-protect (save-window-excursion (delete-other-windows) - (cl-letf (((symbol-function 'env-laptop-p) (lambda () nil))) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'right))) (let ((a1 (get-buffer-create a1-name)) (a2 (get-buffer-create a2-name)) (left-buf (get-buffer-create left-name)) @@ -269,5 +269,46 @@ most-recent agent, which would now be the other one." (when (get-buffer right-name) (kill-buffer right-name)) (cj/test--kill-agent-buffers)))) +(ert-deftest test-ai-term--reuse-edge-window-3win-toggle-restores-own-window () + "Regression: in a 3-window layout the agent has its own split, so toggling it +off then on restores it as its own window without displacing a working window. +Before the fix, toggle-on reused the bottom edge (the user's main window), +collapsing three windows to two and hiding the main buffer. A toggle must be +reversible: off then on returns to the same layout." + (cj/test--kill-agent-buffers) + (let ((agent-name "agent [3win-toggle]") + (code-name "*test-3win-code*") + (main-name "*test-3win-main*") + (cj/--ai-term-last-direction nil) + (cj/--ai-term-last-size nil) + (cj/--ai-term-last-was-bury nil)) + (unwind-protect + (save-window-excursion + (delete-other-windows) + (cl-letf (((symbol-function 'cj/--ai-term-default-direction) (lambda (&rest _) 'below))) + (let ((code-buf (get-buffer-create code-name)) + (main-buf (get-buffer-create main-name)) + (agent-buf (get-buffer-create agent-name))) + (set-window-buffer (selected-window) code-buf) + (let* ((main-win (split-window (selected-window) nil 'below)) + (agent-win (split-window main-win nil 'below))) + (set-window-buffer main-win main-buf) + (set-window-buffer agent-win agent-buf) + (should (= (count-windows) 3)) + (let ((display-buffer-alist (cj/--ai-term-display-rule-list))) + (select-window agent-win) + (cj/test--call-as-gui #'cj/ai-term) ; off -> code | main + (should (= (count-windows) 2)) + (should-not (member agent-name (cj/test--displayed-buffer-names))) + (cj/test--call-as-gui #'cj/ai-term) ; on -> back to 3 windows + (should (= (count-windows) 3)) + (let ((bufs (cj/test--displayed-buffer-names))) + (should (member agent-name bufs)) + (should (member code-name bufs)) + (should (member main-name bufs)))))))) + (when (get-buffer code-name) (kill-buffer code-name)) + (when (get-buffer main-name) (kill-buffer main-name)) + (cj/test--kill-agent-buffers)))) + (provide 'test-ai-term--reuse-edge-window) ;;; test-ai-term--reuse-edge-window.el ends here diff --git a/tests/test-ai-term--show-or-create.el b/tests/test-ai-term--show-or-create.el index c6653dcdd..4f5f1f67f 100644 --- a/tests/test-ai-term--show-or-create.el +++ b/tests/test-ai-term--show-or-create.el @@ -3,13 +3,13 @@ ;;; Commentary: ;; Tests the show-or-create branching: ;; -;; - buffer absent -> ghostel called, agent command + newline sent -;; - buffer present, live -> ghostel not called, buffer displayed -;; - buffer present, dead -> old buffer killed, ghostel recreates +;; - buffer absent -> eat called, agent command + newline sent +;; - buffer present, live -> eat not called, buffer displayed +;; - buffer present, dead -> old buffer killed, eat recreates ;; -;; ghostel functions are stubbed so the test does no process spawning and -;; never loads the native module. Production calls (ghostel) with no name and -;; relies on the dynamically bound `ghostel-buffer-name'; the mock honors that. +;; eat + the send helper are stubbed so the test does no process spawning. +;; Production calls (eat) and relies on the dynamically bound `eat-buffer-name'; +;; the mock honors that. ;;; Code: @@ -19,19 +19,17 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'ai-term) -;; ghostel isn't loaded in batch -- provide stubs so cl-letf has overrides. -(unless (fboundp 'ghostel) - (defun ghostel (&optional _arg) nil)) -(unless (fboundp 'ghostel-send-string) - (defun ghostel-send-string (_s) nil)) +;; eat isn't loaded in batch -- provide a stub so cl-letf has an override. +(unless (fboundp 'eat) + (defun eat (&optional _program _arg) nil)) -(defmacro test-ai-term--with-mock-ghostel (vars &rest body) - "Run BODY with ghostel + ghostel-send-string mocked. +(defmacro test-ai-term--with-mock-eat (vars &rest body) + "Run BODY with eat + `cj/--ai-term-send-string' mocked. -VARS is a plist of capture variable names: :calls (buffer names ghostel -was asked to create), :strings (sent strings), :default-dir. The mocked -`ghostel' creates and returns a buffer named after the dynamically bound -`ghostel-buffer-name', mirroring the real entry point." +VARS is a plist of capture variable names: :calls (buffer names eat was asked +to create), :strings (sent strings), :default-dir. The mocked `eat' creates +and returns a buffer named after the dynamically bound `eat-buffer-name', +mirroring the real entry point." (declare (indent 1) (debug t)) (let ((calls (plist-get vars :calls)) (strings (plist-get vars :strings)) @@ -39,14 +37,14 @@ was asked to create), :strings (sent strings), :default-dir. The mocked `(let ((,calls '()) (,strings '()) (,ddir nil)) - (cl-letf (((symbol-function 'ghostel) - (lambda (&optional _arg) + (cl-letf (((symbol-function 'eat) + (lambda (&optional _program _arg) (setq ,ddir default-directory) - (let ((b (get-buffer-create ghostel-buffer-name))) + (let ((b (get-buffer-create eat-buffer-name))) (push (buffer-name b) ,calls) b))) - ((symbol-function 'ghostel-send-string) - (lambda (s) (push s ,strings)))) + ((symbol-function 'cj/--ai-term-send-string) + (lambda (_buf s) (push s ,strings)))) ,@body)))) (defun test-ai-term--cleanup (name) @@ -55,33 +53,33 @@ was asked to create), :strings (sent strings), :default-dir. The mocked (kill-buffer name))) (ert-deftest test-ai-term--show-or-create-creates-when-buffer-missing () - "Normal: no existing buffer -> ghostel called once, launch cmd + newline -sent, the project recorded at the front of the MRU list." + "Normal: no existing buffer -> eat called once, launch cmd + newline sent, +the project recorded at the front of the MRU list." (let ((name "agent [normal-create-test]") (cj/--ai-term-mru nil)) (test-ai-term--cleanup name) (unwind-protect - (test-ai-term--with-mock-ghostel (:calls calls :strings strings - :default-dir ddir) + (test-ai-term--with-mock-eat (:calls calls :strings strings + :default-dir ddir) (cj/--ai-term-show-or-create "/tmp/some-project" name) (should (equal calls (list name))) - (should (equal (reverse strings) - (list (cj/--ai-term-launch-command "/tmp/some-project") - "\n"))) + (should (equal strings + (list (concat (cj/--ai-term-launch-command "/tmp/some-project") + "\n")))) (should (equal ddir "/tmp/some-project")) (should (equal (car cj/--ai-term-mru) "/tmp/some-project"))) (test-ai-term--cleanup name)))) (ert-deftest test-ai-term--show-or-create-displays-existing-when-process-live () - "Normal: buffer exists with live process -> ghostel not called." + "Normal: buffer exists with live process -> eat not called." (let ((name "agent [reuse-test]")) (test-ai-term--cleanup name) (unwind-protect (let ((buf (get-buffer-create name))) (cl-letf (((symbol-function 'cj/--ai-term-process-live-p) (lambda (b) (and (eq b buf) t)))) - (test-ai-term--with-mock-ghostel (:calls calls :strings strings - :default-dir _ddir) + (test-ai-term--with-mock-eat (:calls calls :strings strings + :default-dir _ddir) (cj/--ai-term-show-or-create "/tmp/reuse" name) (should (null calls)) (should (null strings))))) @@ -95,27 +93,27 @@ sent, the project recorded at the front of the MRU list." (let ((stale (get-buffer-create name))) (cl-letf (((symbol-function 'cj/--ai-term-process-live-p) (lambda (_b) nil))) - (test-ai-term--with-mock-ghostel (:calls calls :strings strings - :default-dir _ddir) + (test-ai-term--with-mock-eat (:calls calls :strings strings + :default-dir _ddir) (cj/--ai-term-show-or-create "/tmp/dead" name) (should (equal calls (list name))) - (should (equal (reverse strings) - (list (cj/--ai-term-launch-command "/tmp/dead") - "\n"))) + (should (equal strings + (list (concat (cj/--ai-term-launch-command "/tmp/dead") + "\n")))) (should-not (buffer-live-p stale))))) (test-ai-term--cleanup name)))) (ert-deftest test-ai-term--show-or-create-preserves-selected-window () - "Regression: ghostel's same-window switch must not bury the dashboard. + "Regression: eat's same-window switch must not bury the dashboard. -Real `ghostel' switches the selected window to its buffer as a side-effect of +Real `eat' switches the selected window to its buffer as a side-effect of construction. On a fresh-boot frame (one window showing the dashboard), that side-effect would otherwise leave the original window pointing at the new -agent buffer. The wrapper runs `(ghostel)' inside `save-window-excursion' so -the original window state is restored before `display-buffer' fires, leaving -the dashboard put and letting the alist place agent into a fresh split. +agent buffer. The wrapper runs `(eat)' inside `save-window-excursion' so the +original window state is restored before `display-buffer' fires, leaving the +dashboard put and letting the alist place agent into a fresh split. -This test stubs `ghostel' to mimic the same-window side-effect and asserts the +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*")) @@ -128,24 +126,24 @@ originally-selected window still shows its original buffer afterward." (orig-win (selected-window))) (set-window-buffer orig-win orig-buf) (cl-letf - (((symbol-function 'ghostel) - (lambda (&optional _arg) - (let ((buf (get-buffer-create ghostel-buffer-name))) + (((symbol-function 'eat) + (lambda (&optional _program _arg) + (let ((buf (get-buffer-create eat-buffer-name))) (set-window-buffer (selected-window) buf) buf))) - ((symbol-function 'ghostel-send-string) - (lambda (_s) nil))) + ((symbol-function 'cj/--ai-term-send-string) + (lambda (_buf _s) nil))) (cj/--ai-term-show-or-create "/tmp/preserve" agent-name) (should (eq (window-buffer orig-win) orig-buf))))) (test-ai-term--cleanup agent-name) (when (get-buffer orig-name) (kill-buffer orig-name))))) (ert-deftest test-ai-term--show-or-create-returns-buffer () - "Normal: return value is the ghostel buffer named after the project." + "Normal: return value is the eat buffer named after the project." (let ((name "agent [return-test]")) (test-ai-term--cleanup name) (unwind-protect - (test-ai-term--with-mock-ghostel (:calls _c :strings _s :default-dir _d) + (test-ai-term--with-mock-eat (:calls _c :strings _s :default-dir _d) (let ((result (cj/--ai-term-show-or-create "/tmp/return" name))) (should (bufferp result)) (should (equal (buffer-name result) name)))) diff --git a/tests/test-ai-term--shutdown-countdown.el b/tests/test-ai-term--shutdown-countdown.el new file mode 100644 index 000000000..6500e9634 --- /dev/null +++ b/tests/test-ai-term--shutdown-countdown.el @@ -0,0 +1,73 @@ +;;; test-ai-term--shutdown-countdown.el --- Tests for the shutdown countdown -*- lexical-binding: t; -*- + +;;; Commentary: +;; The "wrap it up and shutdown" countdown. The testable logic is the safety +;; gate (abort when more than one aiv-* session is live) and the cancel/timer +;; bookkeeping; the tick rendering and the actual shutdown side effect are +;; manual (see the spec). shell-command is stubbed throughout so no test can +;; power the machine off, and timers are cancelled rather than allowed to fire. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(defmacro test-ai-term-shutdown--with (live-count shell-var &rest body) + "Run BODY with `cj/ai-term-live-count' mocked to LIVE-COUNT and `shell-command' +recording its argument into SHELL-VAR; the timer is cleared before and after." + (declare (indent 2)) + `(progn + (cj/--ai-term-shutdown-clear-timer) + (unwind-protect + (cl-letf (((symbol-function 'cj/ai-term-live-count) (lambda () ,live-count)) + ((symbol-function 'shell-command) + (lambda (cmd &rest _) (setq ,shell-var cmd) 0))) + ,@body) + (cj/--ai-term-shutdown-clear-timer)))) + +(ert-deftest test-ai-term-shutdown-aborts-when-other-sessions-live () + "Normal: more than one live session aborts -- no timer, no shutdown." + (let ((shell nil)) + (test-ai-term-shutdown--with 2 shell + (should-not (cj/ai-term-shutdown-countdown 3)) + (should-not cj/--ai-term-shutdown-timer) + (should-not shell)))) + +(ert-deftest test-ai-term-shutdown-schedules-timer-when-sole-session () + "Normal: the sole live session schedules the countdown timer (does not fire here)." + (let ((shell nil)) + (test-ai-term-shutdown--with 1 shell + (cj/ai-term-shutdown-countdown 3) + (should (timerp cj/--ai-term-shutdown-timer)) + ;; The timer has not ticked (no event loop in batch), so no shutdown yet. + (should-not shell)))) + +(ert-deftest test-ai-term-shutdown-cancel-clears-the-timer () + "Normal: cancel stops an in-progress countdown." + (let ((shell nil)) + (test-ai-term-shutdown--with 1 shell + (cj/ai-term-shutdown-countdown 5) + (should (timerp cj/--ai-term-shutdown-timer)) + (cj/ai-term-shutdown-cancel) + (should-not cj/--ai-term-shutdown-timer) + (should-not shell)))) + +(ert-deftest test-ai-term-shutdown-tick-fires-shutdown-at-zero () + "Boundary: invoking the timer function at zero remaining runs the shutdown +command and clears the timer. Drives the tick directly rather than waiting." + (let ((shell nil)) + (test-ai-term-shutdown--with 1 shell + (cj/ai-term-shutdown-countdown 1) + (let ((fn (timer--function cj/--ai-term-shutdown-timer))) + ;; remaining starts at 1: first call renders, second call hits zero. + (funcall fn) + (should-not shell) + (funcall fn) + (should (equal shell cj/ai-term-shutdown-command)) + (should-not cj/--ai-term-shutdown-timer))))) + +(provide 'test-ai-term--shutdown-countdown) +;;; test-ai-term--shutdown-countdown.el ends here diff --git a/tests/test-auth-config--plstore-read-fixed.el b/tests/test-auth-config--plstore-read-fixed.el new file mode 100644 index 000000000..4b14a4a0c --- /dev/null +++ b/tests/test-auth-config--plstore-read-fixed.el @@ -0,0 +1,101 @@ +;;; test-auth-config--plstore-read-fixed.el --- Tests for the oauth2-auto cache fix -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `cj/oauth2-auto--plstore-read-fixed' in auth-config.el — the +;; advice that re-enables oauth2-auto's plstore cache. oauth2-auto is not +;; installed here, so its symbols and the plstore I/O are stubbed at the +;; boundary; the function's own logic (cache-first read, puthash, the +;; unwind-protect close) runs for real. `require' is stubbed to no-op only +;; for oauth2-auto (other requires delegate through), satisfying the +;; function's `(require 'oauth2-auto)' without loading or provide-ing the +;; package (a provide would fire auth-config's advice-add side effect). + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'plstore) +(require 'auth-config) + +;; Declared special so the function (which reads these as free package +;; globals) sees the dynamic let-bindings the tests establish. +(defvar oauth2-auto--plstore-cache nil) +(defvar oauth2-auto-plstore nil) + +(defvar test-auth--open-count 0 "Times plstore-open was called in a test.") +(defvar test-auth--closed nil "Whether plstore-close ran in a test.") +(defvar test-auth--get-fn nil "Stub behavior for plstore-get: (lambda (ps id) ...).") + +(defmacro test-auth--with-env (&rest body) + "Run BODY with a faked oauth2-auto + plstore environment. +Resets the open counter and closed flag and gives a fresh cache each time." + (declare (indent 0)) + `(let* ((oauth2-auto--plstore-cache (make-hash-table :test 'equal)) + (oauth2-auto-plstore "/tmp/oauth2-test.plist") + (test-auth--open-count 0) + (test-auth--closed nil) + (orig-require (symbol-function 'require))) + (cl-letf (((symbol-function 'require) + (lambda (feat &rest args) + (if (eq feat 'oauth2-auto) + 'oauth2-auto + (apply orig-require feat args)))) + ((symbol-function 'oauth2-auto--compute-id) + (lambda (_u _p) "ID")) + ((symbol-function 'plstore-open) + (lambda (_f) (cl-incf test-auth--open-count) 'PS)) + ((symbol-function 'plstore-get) + (lambda (ps id) (funcall test-auth--get-fn ps id))) + ((symbol-function 'plstore-close) + (lambda (_p) (setq test-auth--closed t)))) + ,@body))) + +;;; Normal Cases + +(ert-deftest test-auth-config-plstore-read-fixed-cache-hit () + "Normal: a cache hit returns the cached value without opening the plstore." + (let ((test-auth--get-fn (lambda (_ps _id) (error "should not read")))) + (test-auth--with-env + (puthash "ID" "CACHED" oauth2-auto--plstore-cache) + (should (equal (cj/oauth2-auto--plstore-read-fixed "u" "p") "CACHED")) + (should (= test-auth--open-count 0))))) + +(ert-deftest test-auth-config-plstore-read-fixed-cache-miss-reads-and-caches () + "Normal: a miss reads from the plstore, caches the value, and closes." + (let ((test-auth--get-fn (lambda (_ps id) (cons id "TOK")))) + (test-auth--with-env + (should (equal (cj/oauth2-auto--plstore-read-fixed "u" "p") "TOK")) + (should (equal (gethash "ID" oauth2-auto--plstore-cache) "TOK")) + (should (= test-auth--open-count 1)) + (should test-auth--closed)))) + +;;; Boundary Cases + +(ert-deftest test-auth-config-plstore-read-fixed-value-cached-after-first-read () + "Boundary: a non-nil value is cached, so a second call does not re-open." + (let ((test-auth--get-fn (lambda (_ps id) (cons id "TOK")))) + (test-auth--with-env + (cj/oauth2-auto--plstore-read-fixed "u" "p") + (cj/oauth2-auto--plstore-read-fixed "u" "p") + (should (= test-auth--open-count 1))))) + +(ert-deftest test-auth-config-plstore-read-fixed-nil-value-rereads () + "Boundary: a nil value caches nil, so every call re-opens the plstore. +This documents current behavior — `gethash' on a nil entry is a miss." + (let ((test-auth--get-fn (lambda (_ps _id) (cons "ID" nil)))) + (test-auth--with-env + (should-not (cj/oauth2-auto--plstore-read-fixed "u" "p")) + (should-not (cj/oauth2-auto--plstore-read-fixed "u" "p")) + (should (= test-auth--open-count 2))))) + +;;; Error Cases + +(ert-deftest test-auth-config-plstore-read-fixed-closes-on-error () + "Error: a read failure still closes the plstore via unwind-protect." + (let ((test-auth--get-fn (lambda (&rest _) (error "boom")))) + (test-auth--with-env + (should-error (cj/oauth2-auto--plstore-read-fixed "u" "p")) + (should test-auth--closed)))) + +(provide 'test-auth-config--plstore-read-fixed) +;;; test-auth-config--plstore-read-fixed.el ends here diff --git a/tests/test-browser-config.el b/tests/test-browser-config.el index 7faecbfc8..9fe5b02e4 100644 --- a/tests/test-browser-config.el +++ b/tests/test-browser-config.el @@ -273,29 +273,6 @@ (should (string= (plist-get loaded :name) "Second")))) (test-browser-teardown)) -;;; Public wrappers (message side-effects mocked) - -(ert-deftest test-browser-apply-wrapper-success-messages-name () - "Normal: =cj/apply-browser-choice= reports the chosen name on success." - (test-browser-setup) - (let ((browser (test-browser-make-plist "Wrapper Test")) - (received nil)) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq received (apply #'format fmt args))))) - (cj/apply-browser-choice browser)) - (should (string-match-p "Wrapper Test" received)) - (should (string-match-p "Default browser set" received))) - (test-browser-teardown)) - -(ert-deftest test-browser-apply-wrapper-invalid-plist-messages-error () - "Error: =cj/apply-browser-choice= surfaces an error message for a bad plist." - (test-browser-setup) - (let ((received nil)) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq received (apply #'format fmt args))))) - (cj/apply-browser-choice nil)) - (should (string-match-p "Invalid" received))) - (test-browser-teardown)) (ert-deftest test-browser-initialize-wrapper-loaded-branch-applies () "Normal: =cj/initialize-browser= applies the saved browser when one is loaded." diff --git a/tests/test-build-theme.el b/tests/test-build-theme.el index 87b17e0a4..8793da73a 100644 --- a/tests/test-build-theme.el +++ b/tests/test-build-theme.el @@ -1,4 +1,4 @@ -;;; test-build-theme.el --- Tests for the theme.json -> dupre-*.el converter -*- lexical-binding: t -*- +;;; test-build-theme.el --- Tests for the theme.json -> deftheme converter -*- lexical-binding: t -*- ;;; Commentary: @@ -34,12 +34,14 @@ "{ \"name\": \"dupre-fixture\", \"palette\": [[\"#000000\",\"ground\"],[\"#7a9abe\",\"blue\"],[\"#84b068\",\"green\"]], - \"assignments\": { - \"bg\":\"#000000\", \"p\":\"#cdced1\", - \"kw\":\"#7a9abe\", \"str\":\"#84b068\", \"cm\":\"#838d97\", \"dec\":\"#e8bd30\" + \"syntax\": { + \"bg\": {\"fg\":\"#000000\",\"bg\":null,\"bold\":false,\"italic\":false}, + \"p\": {\"fg\":\"#cdced1\",\"bg\":null,\"bold\":false,\"italic\":false}, + \"kw\": {\"fg\":\"#7a9abe\",\"bg\":null,\"bold\":true,\"italic\":false}, + \"str\":{\"fg\":\"#84b068\",\"bg\":null,\"bold\":false,\"italic\":false}, + \"cm\": {\"fg\":\"#838d97\",\"bg\":null,\"bold\":false,\"italic\":true}, + \"dec\":{\"fg\":\"#e8bd30\",\"bg\":null,\"bold\":false,\"italic\":false} }, - \"bold\": [\"kw\"], - \"italic\": [\"cm\"], \"ui\": { \"region\": {\"fg\":null, \"bg\":\"#264364\"}, \"mode-line\": {\"fg\":\"#cdced1\", \"bg\":\"#2f343a\"} @@ -54,8 +56,10 @@ }" "A self-contained theme.json exercising every tier: default, syntax (bold + italic + the unmappable dec key), UI, and packages (a plain face, an -inherit+height face, and a cleared face). Owned by the test so it can't drift -the way Craig's downloaded exports under scripts/theme-studio/ can.") +inherit+height face, and a cleared face). Uses the nested \"syntax\" format the +converter reads -- each category is an object with fg/bg/bold/italic, and bg/p +are themselves category objects carrying fg. Owned by the test so it can't +drift the way Craig's downloaded exports under scripts/theme-studio/ can.") (defun test-build-theme--write-fixture (dir) "Write the fixture JSON into DIR and return its path." @@ -70,7 +74,7 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") (unwind-protect (progn ,@body) (delete-directory ,var t)))) -;; --- WCAG contrast helpers (mirror of the dupre-theme test helpers) --- +;; --- WCAG contrast helpers --- (defun test-build-theme--channel-luminance (c) "Linearize an 8-bit channel value C (0-255) per the WCAG formula." @@ -91,43 +95,175 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") ;;; --------------------------------------------------------------------------- ;;; build-theme/--attrs (the core attribute builder) +;; +;; `--attrs' takes one face-spec alist and emits a face-attribute plist. It +;; reads the full attribute model and tolerates the legacy boolean +;; bold/italic/underline/strike fields that older theme.json exports carry. -(ert-deftest test-build-theme-attrs-fg-and-bold () - "Normal: a foreground plus bold yields :foreground and :weight bold." - (should (equal (build-theme/--attrs nil "#67809c" nil t nil nil nil nil) +;; --- Legacy boolean fields still work (back-compat with committed presets) --- + +(ert-deftest test-build-theme-attrs-legacy-fg-and-bold () + "Normal: legacy bold flag yields :weight bold." + (should (equal (build-theme/--attrs '((fg . "#67809c") (bold . t))) '(:foreground "#67809c" :weight bold)))) -(ert-deftest test-build-theme-attrs-full-ordering () - "Normal: every attribute present, in canonical order." - (should (equal (build-theme/--attrs 'org-level-1 "#e8bd30" "#1a1714" t t t t 1.3) - '(:inherit org-level-1 :foreground "#e8bd30" :background "#1a1714" - :weight bold :slant italic :underline t :strike-through t :height 1.3)))) - -(ert-deftest test-build-theme-attrs-underline-and-strike () - "Normal: underline and strike yield :underline t and :strike-through t." - (should (equal (build-theme/--attrs nil "#67809c" nil nil nil t t nil) - '(:foreground "#67809c" :underline t :strike-through t))) - ;; either alone - (should (equal (build-theme/--attrs nil nil nil nil nil t nil nil) - '(:underline t))) - (should (equal (build-theme/--attrs nil nil nil nil nil nil t nil) - '(:strike-through t)))) +(ert-deftest test-build-theme-attrs-legacy-italic-underline-strike () + "Normal: legacy italic/underline/strike booleans map to their attributes." + (should (equal (build-theme/--attrs '((italic . t))) '(:slant italic))) + (should (equal (build-theme/--attrs '((underline . t))) '(:underline t))) + (should (equal (build-theme/--attrs '((strike . t))) '(:strike-through t)))) (ert-deftest test-build-theme-attrs-empty-is-nil () - "Boundary: a fully-cleared face (all nil) yields an empty plist." - (should (equal (build-theme/--attrs nil nil nil nil nil nil nil nil) '()))) + "Boundary: a blank face (empty alist, or all-nil fields) yields an empty plist." + (should (equal (build-theme/--attrs '()) '())) + (should (equal (build-theme/--attrs '((fg) (bg) (bold) (italic) (underline) (strike))) '()))) (ert-deftest test-build-theme-attrs-bold-false-omits-weight () - "Boundary: bold false produces no :weight key (only overrides are written)." - (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil nil) - '(:foreground "#cdced1")))) + "Boundary: bold false (or absent) writes no :weight -- only overrides appear." + (should (equal (build-theme/--attrs '((fg . "#cdced1") (bold . nil))) + '(:foreground "#cdced1"))) + (should (equal (build-theme/--attrs '((fg . "#cdced1"))) '(:foreground "#cdced1")))) (ert-deftest test-build-theme-attrs-height-one-omitted () - "Boundary: a height of exactly 1.0 is omitted (the default multiplier)." - (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil 1.0) - '(:foreground "#cdced1"))) - (should (equal (build-theme/--attrs nil "#cdced1" nil nil nil nil nil 1) - '(:foreground "#cdced1")))) + "Boundary: a height of exactly 1.0 (or integer 1) is omitted as the default." + (should (equal (build-theme/--attrs '((fg . "#cdced1") (height . 1.0))) '(:foreground "#cdced1"))) + (should (equal (build-theme/--attrs '((fg . "#cdced1") (height . 1))) '(:foreground "#cdced1"))) + (should (equal (build-theme/--attrs '((height . 1.2))) '(:height 1.2)))) + +;; --- New attributes --- + +(ert-deftest test-build-theme-attrs-family () + "Normal/Boundary: a non-empty family string emits :family; empty is omitted." + (should (equal (build-theme/--attrs '((family . "Iosevka"))) '(:family "Iosevka"))) + (should (equal (build-theme/--attrs '((family . ""))) '())) + (should (equal (build-theme/--attrs '((family . nil))) '()))) + +(ert-deftest test-build-theme-attrs-distant-foreground () + "Normal: distant-fg emits :distant-foreground." + (should (equal (build-theme/--attrs '((distant-fg . "#ffffff"))) + '(:distant-foreground "#ffffff")))) + +(ert-deftest test-build-theme-attrs-weight-range () + "Normal: an explicit weight string emits that weight symbol." + (should (equal (build-theme/--attrs '((weight . "light"))) '(:weight light))) + (should (equal (build-theme/--attrs '((weight . "semibold"))) '(:weight semibold))) + (should (equal (build-theme/--attrs '((weight . "heavy"))) '(:weight heavy)))) + +(ert-deftest test-build-theme-attrs-weight-overrides-legacy-bold () + "Boundary: an explicit weight wins over a legacy bold flag on the same face." + (should (equal (build-theme/--attrs '((weight . "light") (bold . t))) + '(:weight light)))) + +(ert-deftest test-build-theme-attrs-slant-range () + "Normal: an explicit slant string emits that slant; it wins over legacy italic." + (should (equal (build-theme/--attrs '((slant . "oblique"))) '(:slant oblique))) + (should (equal (build-theme/--attrs '((slant . "normal"))) '(:slant normal))) + (should (equal (build-theme/--attrs '((slant . "oblique") (italic . t))) '(:slant oblique)))) + +(ert-deftest test-build-theme-attrs-underline-object () + "Normal/Boundary: the structured underline form covers line/wave and color." + ;; plain line in the face color collapses to t + (should (equal (build-theme/--attrs '((underline . ((style . "line") (color . nil))))) + '(:underline t))) + ;; wave alone -> a :style plist + (should (equal (build-theme/--attrs '((underline . ((style . "wave") (color . nil))))) + '(:underline (:style wave)))) + ;; colored line -> a :color plist + (should (equal (build-theme/--attrs '((underline . ((style . "line") (color . "#cb6b4d"))))) + '(:underline (:color "#cb6b4d")))) + ;; colored wave -> both + (should (equal (build-theme/--attrs '((underline . ((style . "wave") (color . "#cb6b4d"))))) + '(:underline (:color "#cb6b4d" :style wave))))) + +(ert-deftest test-build-theme-attrs-strike-object () + "Normal: structured strike emits t for no color, or the color string." + (should (equal (build-theme/--attrs '((strike . ((color . nil))))) '(:strike-through t))) + (should (equal (build-theme/--attrs '((strike . ((color . "#cb6b4d"))))) + '(:strike-through "#cb6b4d")))) + +(ert-deftest test-build-theme-attrs-migrated-shapes-match-legacy () + "Boundary: the shapes the import migration produces emit identically to the +legacy booleans they replace, so the cutover keeps generated themes byte-identical. +Mirrors migrateLegacyFace (app-core.js) / migrate_legacy (face_specs.py)." + (should (equal (build-theme/--attrs '((weight . "bold"))) + (build-theme/--attrs '((bold . t))))) + (should (equal (build-theme/--attrs '((slant . "italic"))) + (build-theme/--attrs '((italic . t))))) + (should (equal (build-theme/--attrs '((underline . ((style . "line") (color . nil))))) + (build-theme/--attrs '((underline . t))))) + (should (equal (build-theme/--attrs '((strike . ((color . nil))))) + (build-theme/--attrs '((strike . t)))))) + +(ert-deftest test-build-theme-attrs-overline () + "Normal/Boundary: overline emits t for no color, the color otherwise, nil when unset." + (should (equal (build-theme/--attrs '((overline . ((color . nil))))) '(:overline t))) + (should (equal (build-theme/--attrs '((overline . ((color . "#a9b2bb"))))) + '(:overline "#a9b2bb"))) + (should (equal (build-theme/--attrs '((overline . nil))) '()))) + +(ert-deftest test-build-theme-attrs-inverse-and-extend () + "Normal/Boundary: inverse and extend emit t when set, nothing when nil." + (should (equal (build-theme/--attrs '((inverse . t))) '(:inverse-video t))) + (should (equal (build-theme/--attrs '((extend . t))) '(:extend t))) + (should (equal (build-theme/--attrs '((inverse . t) (extend . t))) + '(:inverse-video t :extend t))) + (should (equal (build-theme/--attrs '((inverse . nil) (extend . nil))) '()))) + +(ert-deftest test-build-theme-attrs-inherit-any-tier () + "Normal: inherit coerces a face-name string to a symbol (now allowed on every tier)." + (should (equal (build-theme/--attrs '((inherit . "shadow"))) '(:inherit shadow))) + (should (equal (build-theme/--attrs '((inherit . shadow))) '(:inherit shadow))) + (should (equal (build-theme/--attrs '((inherit . nil))) '()))) + +(ert-deftest test-build-theme-attrs-full-ordering () + "Normal: every attribute present, emitted in canonical order." + (should (equal (build-theme/--attrs + '((inherit . "org-level-1") (family . "Iosevka") + (fg . "#e8bd30") (bg . "#1a1714") (distant-fg . "#ffffff") + (weight . "semibold") (slant . "italic") (height . 1.3) + (underline . ((style . "wave") (color . "#cb6b4d"))) + (overline . ((color . "#a9b2bb"))) + (strike . ((color . nil))) + (box . ((style . "line") (color . "#67809c"))) + (inverse . t) (extend . t))) + '(:inherit org-level-1 :family "Iosevka" + :foreground "#e8bd30" :background "#1a1714" :distant-foreground "#ffffff" + :weight semibold :slant italic :height 1.3 + :underline (:color "#cb6b4d" :style wave) :overline "#a9b2bb" + :strike-through t :box (:line-width 1 :color "#67809c") + :inverse-video t :extend t)))) + +;; --- Attribute-helper edge cases (the coercion functions in isolation) --- + +(ert-deftest test-build-theme-weight-helper () + "Boundary: weight prefers explicit string, falls back to bold, else nil." + (should (eq (build-theme/--weight '((weight . "bold"))) 'bold)) + (should (eq (build-theme/--weight '((weight . "light") (bold . t))) 'light)) + (should (eq (build-theme/--weight '((bold . t))) 'bold)) + (should (null (build-theme/--weight '((weight . "") (bold . nil))))) + (should (null (build-theme/--weight '())))) + +(ert-deftest test-build-theme-slant-helper () + "Boundary: slant prefers explicit string, falls back to italic, else nil." + (should (eq (build-theme/--slant '((slant . "oblique"))) 'oblique)) + (should (eq (build-theme/--slant '((italic . t))) 'italic)) + (should (null (build-theme/--slant '((slant . ""))))) + (should (null (build-theme/--slant '())))) + +(ert-deftest test-build-theme-underline-helper () + "Boundary: underline coercion across nil / legacy t / structured forms." + (should (null (build-theme/--underline '((underline . nil))))) + (should (eq (build-theme/--underline '((underline . t))) t)) + (should (eq (build-theme/--underline '((underline . ((style . "line") (color . nil))))) t)) + (should (equal (build-theme/--underline '((underline . ((style . "wave"))))) '(:style wave))) + (should (equal (build-theme/--underline '((underline . ((color . "#aa0000"))))) '(:color "#aa0000")))) + +(ert-deftest test-build-theme-line-attr-helper () + "Boundary: the overline/strike coercion: nil / t / {color} forms." + (should (null (build-theme/--line-attr nil))) + (should (eq (build-theme/--line-attr t) t)) + (should (eq (build-theme/--line-attr '((color . nil))) t)) + (should (equal (build-theme/--line-attr '((color . "#abcdef"))) "#abcdef"))) ;;; --------------------------------------------------------------------------- ;;; build-theme/--face-spec (skips empty faces) @@ -145,9 +281,11 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") ;;; Syntax tier (ert-deftest test-build-theme-syntax-keyword-bold () - "Normal: kw maps to font-lock-keyword-face and picks up the bold set." - (let* ((assignments '((kw . "#7a9abe") (str . "#84b068"))) - (specs (build-theme/--syntax-face-specs assignments '(kw) '()))) + "Normal: kw maps to font-lock-keyword-face and carries its bold flag. +Each syntax category is a nested object with fg/bold/italic." + (let* ((syntax '((kw . ((fg . "#7a9abe") (bold . t))) + (str . ((fg . "#84b068"))))) + (specs (build-theme/--syntax-face-specs syntax))) (should (member '(font-lock-keyword-face ((t (:foreground "#7a9abe" :weight bold)))) specs)) (should (member '(font-lock-string-face ((t (:foreground "#84b068")))) @@ -155,7 +293,7 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") (ert-deftest test-build-theme-syntax-one-to-many () "Normal: punc fans out to every punctuation/bracket/delimiter face." - (let ((specs (build-theme/--syntax-face-specs '((punc . "#a9b2bb")) '() '()))) + (let ((specs (build-theme/--syntax-face-specs '((punc . ((fg . "#a9b2bb"))))))) (dolist (face '(font-lock-punctuation-face font-lock-bracket-face font-lock-delimiter-face font-lock-misc-punctuation-face)) (should (member `(,face ((t (:foreground "#a9b2bb")))) specs))))) @@ -164,12 +302,12 @@ the way Craig's downloaded exports under scripts/theme-studio/ can.") "Boundary: dec has no independent Emacs face, so it maps to nothing. Emacs renders decorators with font-lock-type-face, which ty already owns; mapping dec would clobber the type color." - (let ((specs (build-theme/--syntax-face-specs '((dec . "#e8bd30")) '() '()))) + (let ((specs (build-theme/--syntax-face-specs '((dec . ((fg . "#e8bd30"))))))) (should (null specs)))) (ert-deftest test-build-theme-syntax-comment-italic () - "Normal: cm in the italic set yields :slant italic on the comment face." - (let ((specs (build-theme/--syntax-face-specs '((cm . "#a9b2bb")) '() '(cm)))) + "Normal: cm with its italic flag yields :slant italic on the comment face." + (let ((specs (build-theme/--syntax-face-specs '((cm . ((fg . "#a9b2bb") (italic . t))))))) (should (member '(font-lock-comment-face ((t (:foreground "#a9b2bb" :slant italic)))) specs)))) @@ -177,8 +315,9 @@ mapping dec would clobber the type color." ;;; Default face (ert-deftest test-build-theme-default-face () - "Normal: default takes background from bg and foreground from p." - (should (equal (build-theme/--default-spec '((bg . "#000000") (p . "#cdced1"))) + "Normal: default takes background from syntax.bg.fg and foreground from syntax.p.fg." + (should (equal (build-theme/--default-spec '((bg . ((fg . "#000000"))) + (p . ((fg . "#cdced1"))))) '(default ((t (:foreground "#cdced1" :background "#000000"))))))) ;;; --------------------------------------------------------------------------- @@ -294,7 +433,7 @@ including an inherit+height package face." (ert-deftest test-build-theme-convert-file-old-json-without-packages () "Boundary: a theme.json with no packages key still converts and loads." (test-build-theme--with-sandbox out - (let* ((json "{\"name\":\"noformat\",\"palette\":[[\"#000000\",\"ground\"]],\"assignments\":{\"bg\":\"#000000\",\"p\":\"#ffffff\",\"kw\":\"#67809c\"},\"bold\":[\"kw\"],\"italic\":[],\"ui\":{}}") + (let* ((json "{\"name\":\"noformat\",\"palette\":[[\"#000000\",\"ground\"]],\"syntax\":{\"bg\":{\"fg\":\"#000000\"},\"p\":{\"fg\":\"#ffffff\"},\"kw\":{\"fg\":\"#67809c\",\"bold\":true}},\"ui\":{}}") (in (expand-file-name "noformat.json" out))) (with-temp-file in (insert json)) (let ((path (build-theme/convert-file in out))) @@ -313,6 +452,25 @@ including an inherit+height package face." (test-build-theme--with-sandbox out (should-error (build-theme/convert-file (expand-file-name "does-not-exist.json" out) out)))) +(ert-deftest test-build-theme-name-from-filename-not-json-field () + "Normal/Regression: the output name comes from the JSON file's basename, not +its internal name field, so each draft exports under its own name (a WIP.json +becomes WIP-theme.el, never theme-theme.el)." + (test-build-theme--with-sandbox out + ;; The fixture's internal name field is \"dupre-fixture\"; the file is sterling.json. + (let ((in (expand-file-name "sterling.json" out))) + (with-temp-file in (insert test-build-theme--fixture-json)) + (let ((path (build-theme/convert-file in out))) + (should (string-suffix-p "sterling-theme.el" path)) + (should-not (string-match-p "dupre-fixture" path)) + (let ((custom-theme-load-path (cons out custom-theme-load-path)) + (load-path (cons out load-path))) + (unwind-protect + (progn + (load-theme 'sterling t) + (should (string= (face-attribute 'default :background nil t) "#000000"))) + (disable-theme 'sterling))))))) + (ert-deftest test-build-theme-generated-default-meets-wcag-aa () "Error/Regression: the generated default face stays legible. A WCAG-AA (>= 4.5:1) assertion on the round-tripped result -- proves the whole @@ -329,5 +487,46 @@ parse -> spec -> file -> face pipeline preserves the designed contrast." (should (>= (test-build-theme--contrast fg bg) 4.5)))) (disable-theme 'dupre-fixture)))))) +(ert-deftest test-build-theme-convert-file-new-attributes-round-trip () + "Integration: the new attribute model survives parse -> spec -> file -> face. +Components integrated: +- build-theme/convert-file (entry point, real) +- json parsing of the inline fixture (real) +- custom-theme-set-faces / load-theme / face-attribute (real) +Exercises extend, structured underline (wave + color), overline, inverse-video, +distant-foreground, family, and the weight/slant ranges across the UI and +package tiers." + (test-build-theme--with-sandbox out + (let* ((json "{\"name\":\"newattrs\",\"palette\":[[\"#000000\",\"ground\"]], + \"syntax\":{\"bg\":{\"fg\":\"#000000\"},\"p\":{\"fg\":\"#ffffff\"}}, + \"ui\":{ + \"region\":{\"bg\":\"#264364\",\"extend\":true}, + \"highlight\":{\"fg\":\"#eddba7\",\"underline\":{\"style\":\"wave\",\"color\":\"#cb6b4d\"},\"overline\":{\"color\":\"#a9b2bb\"}}, + \"secondary-selection\":{\"bg\":\"#333333\",\"inverse\":true,\"distant-fg\":\"#ffffff\"} + }, + \"packages\":{ + \"misc\":{ + \"shadow\":{\"fg\":\"#cdced1\",\"family\":\"Iosevka\",\"weight\":\"light\",\"slant\":\"oblique\",\"source\":\"user\"} + } + }}") + (in (expand-file-name "newattrs.json" out))) + (with-temp-file in (insert json)) + (build-theme/convert-file in out) + (let ((custom-theme-load-path (cons out custom-theme-load-path)) + (load-path (cons out load-path))) + (unwind-protect + (progn + (load-theme 'newattrs t) + (should (eq (face-attribute 'region :extend nil t) t)) + (should (equal (face-attribute 'highlight :underline nil t) + '(:color "#cb6b4d" :style wave))) + (should (string= (face-attribute 'highlight :overline nil t) "#a9b2bb")) + (should (eq (face-attribute 'secondary-selection :inverse-video nil t) t)) + (should (string= (face-attribute 'secondary-selection :distant-foreground nil t) "#ffffff")) + (should (string= (face-attribute 'shadow :family nil t) "Iosevka")) + (should (eq (face-attribute 'shadow :weight nil t) 'light)) + (should (eq (face-attribute 'shadow :slant nil t) 'oblique))) + (disable-theme 'newattrs)))))) + (provide 'test-build-theme) ;;; test-build-theme.el ends here diff --git a/tests/test-calendar-sync--apply-single-exception.el b/tests/test-calendar-sync--apply-single-exception.el index 2fcf7c718..f23104d98 100644 --- a/tests/test-calendar-sync--apply-single-exception.el +++ b/tests/test-calendar-sync--apply-single-exception.el @@ -63,5 +63,84 @@ (let ((result (calendar-sync--apply-single-exception occ exc))) (should (equal "Keep" (plist-get result :summary)))))) +;;; Normal Cases — remaining overridable fields + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-description () + "Normal: an exception :description overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :description "old")) + (exc (list :start '(2026 3 15 14 0) :description "new"))) + (should (equal "new" + (plist-get (calendar-sync--apply-single-exception occ exc) + :description))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-location () + "Normal: an exception :location overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :location "Room A")) + (exc (list :start '(2026 3 15 14 0) :location "Room B"))) + (should (equal "Room B" + (plist-get (calendar-sync--apply-single-exception occ exc) + :location))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-attendees () + "Normal: an exception :attendees overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :attendees '("a"))) + (exc (list :start '(2026 3 15 14 0) :attendees '("b" "c")))) + (should (equal '("b" "c") + (plist-get (calendar-sync--apply-single-exception occ exc) + :attendees))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-organizer () + "Normal: an exception :organizer overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :organizer "old@x")) + (exc (list :start '(2026 3 15 14 0) :organizer "new@x"))) + (should (equal "new@x" + (plist-get (calendar-sync--apply-single-exception occ exc) + :organizer))))) + +(ert-deftest test-calendar-sync--apply-single-exception-overrides-url () + "Normal: an exception :url overrides the occurrence's." + (let ((occ (list :start '(2026 3 15 14 0) :url "http://old")) + (exc (list :start '(2026 3 15 14 0) :url "http://new"))) + (should (equal "http://new" + (plist-get (calendar-sync--apply-single-exception occ exc) + :url))))) + +;;; Status re-derivation from overridden attendees (chime handoff 2026-06-24) + +(ert-deftest test-calendar-sync--apply-single-exception-declined-occurrence-rederives-status () + "Normal: a declined single occurrence re-derives :status from the override attendees." + (let ((calendar-sync-user-emails '("craig@example.com")) + (occ (list :start '(2026 6 24 16 0) :status "accepted" :uid "abc")) + (exc (list :start '(2026 6 24 16 0) + :attendees (list (list :email "craig@example.com" :partstat "DECLINED"))))) + (should (equal "declined" + (plist-get (calendar-sync--apply-single-exception occ exc) :status))))) + +(ert-deftest test-calendar-sync--apply-single-exception-no-attendee-override-keeps-status () + "Boundary: an exception with no attendee block leaves the inherited :status intact." + (let ((calendar-sync-user-emails '("craig@example.com")) + (occ (list :start '(2026 6 24 16 0) :status "accepted" :uid "abc")) + (exc (list :start '(2026 6 24 16 0) :summary "Moved"))) + (should (equal "accepted" + (plist-get (calendar-sync--apply-single-exception occ exc) :status))))) + +(ert-deftest test-calendar-sync--apply-single-exception-accepted-override-stays-accepted () + "Normal: an accepted attendee override keeps :status accepted." + (let ((calendar-sync-user-emails '("craig@example.com")) + (occ (list :start '(2026 6 24 16 0) :status "accepted" :uid "abc")) + (exc (list :start '(2026 6 24 16 0) + :attendees (list (list :email "craig@example.com" :partstat "ACCEPTED"))))) + (should (equal "accepted" + (plist-get (calendar-sync--apply-single-exception occ exc) :status))))) + +(ert-deftest test-calendar-sync--apply-single-exception-override-without-user-keeps-status () + "Boundary: override attendees that don't include the user leave :status intact." + (let ((calendar-sync-user-emails '("craig@example.com")) + (occ (list :start '(2026 6 24 16 0) :status "accepted" :uid "abc")) + (exc (list :start '(2026 6 24 16 0) + :attendees (list (list :email "someone@else.com" :partstat "DECLINED"))))) + (should (equal "accepted" + (plist-get (calendar-sync--apply-single-exception occ exc) :status))))) + (provide 'test-calendar-sync--apply-single-exception) ;;; test-calendar-sync--apply-single-exception.el ends here diff --git a/tests/test-calendar-sync--expand-recurring-event.el b/tests/test-calendar-sync--expand-recurring-event.el new file mode 100644 index 000000000..41f0afa9c --- /dev/null +++ b/tests/test-calendar-sync--expand-recurring-event.el @@ -0,0 +1,106 @@ +;;; test-calendar-sync--expand-recurring-event.el --- Tests for recurrence dispatch -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for calendar-sync--expand-recurring-event — the dispatcher that maps +;; an RRULE frequency to the matching expander and applies EXDATE filtering. +;; The individual expanders, parser, and exdate helpers have their own tests; +;; here they are stubbed at the boundary so only the dispatch and the +;; exdate-vs-no-exdate branch are exercised. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'testutil-calendar-sync) +(require 'calendar-sync) + +(defmacro test-cs-ere--with (overrides &rest body) + "Run BODY with the recurrence helpers stubbed. +OVERRIDES is an extra list of cl-letf* bindings layered on the defaults: +RRULE present, parse-event returns 'BASE, no exdates, and every expander +errors if called (each test re-binds the one it expects). cl-letf* is +sequential, so a re-bound place in OVERRIDES wins over the default." + (declare (indent 1)) + `(cl-letf* (((symbol-function 'calendar-sync--get-property) + (lambda (_e prop) (when (string= prop "RRULE") "R"))) + ((symbol-function 'calendar-sync--parse-event) (lambda (_e) 'BASE)) + ((symbol-function 'calendar-sync--collect-exdates) (lambda (_e) nil)) + ((symbol-function 'calendar-sync--expand-daily) + (lambda (&rest _) (error "daily should not be called"))) + ((symbol-function 'calendar-sync--expand-weekly) + (lambda (&rest _) (error "weekly should not be called"))) + ((symbol-function 'calendar-sync--expand-monthly) + (lambda (&rest _) (error "monthly should not be called"))) + ((symbol-function 'calendar-sync--expand-yearly) + (lambda (&rest _) (error "yearly should not be called"))) + ((symbol-function 'calendar-sync--filter-exdates) + (lambda (&rest _) (error "filter-exdates should not be called"))) + ,@overrides) + ,@body)) + +;;; Normal Cases — frequency dispatch + +(ert-deftest test-calendar-sync--expand-recurring-event-dispatches-daily () + "Normal: FREQ=DAILY routes to the daily expander." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--expand-daily) (lambda (&rest _) '(DAILY)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(DAILY))))) + +(ert-deftest test-calendar-sync--expand-recurring-event-dispatches-monthly () + "Normal: FREQ=MONTHLY routes to the monthly expander." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq monthly))) + ((symbol-function 'calendar-sync--expand-monthly) (lambda (&rest _) '(MONTHLY)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(MONTHLY))))) + +(ert-deftest test-calendar-sync--expand-recurring-event-dispatches-yearly () + "Normal: FREQ=YEARLY routes to the yearly expander." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq yearly))) + ((symbol-function 'calendar-sync--expand-yearly) (lambda (&rest _) '(YEARLY)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(YEARLY))))) + +;;; Boundary / Error Cases + +(ert-deftest test-calendar-sync--expand-recurring-event-unsupported-freq-nil () + "Error: an unsupported frequency expands to nil, no expander called." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq hourly)))) + (should-not (calendar-sync--expand-recurring-event "evt" 'range)))) + +(ert-deftest test-calendar-sync--expand-recurring-event-no-rrule-nil () + "Boundary: an event with no RRULE returns nil (not a recurring event)." + (test-cs-ere--with + (((symbol-function 'calendar-sync--get-property) (lambda (&rest _) nil))) + (should-not (calendar-sync--expand-recurring-event "evt" 'range)))) + +(ert-deftest test-calendar-sync--expand-recurring-event-unparseable-base-nil () + "Boundary: when the base event fails to parse, expansion returns nil." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--parse-event) (lambda (_e) nil))) + (should-not (calendar-sync--expand-recurring-event "evt" 'range)))) + +;;; EXDATE branch + +(ert-deftest test-calendar-sync--expand-recurring-event-applies-exdate-filter () + "Normal: with exdates present, occurrences pass through the exdate filter." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--expand-daily) (lambda (&rest _) '(O1 O2))) + ((symbol-function 'calendar-sync--collect-exdates) (lambda (_e) '(EX))) + ((symbol-function 'calendar-sync--filter-exdates) + (lambda (occs _ex) (remq 'O2 occs)))) + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(O1))))) + +(ert-deftest test-calendar-sync--expand-recurring-event-no-exdate-skips-filter () + "Boundary: with no exdates, the filter is skipped and occurrences pass through." + (test-cs-ere--with + (((symbol-function 'calendar-sync--parse-rrule) (lambda (_r) '(:freq daily))) + ((symbol-function 'calendar-sync--expand-daily) (lambda (&rest _) '(O1 O2)))) + ;; filter-exdates stays the error stub; it must not be called here + (should (equal (calendar-sync--expand-recurring-event "evt" 'range) '(O1 O2))))) + +(provide 'test-calendar-sync--expand-recurring-event) +;;; test-calendar-sync--expand-recurring-event.el ends here diff --git a/tests/test-calendar-sync--get-all-property-lines.el b/tests/test-calendar-sync--get-all-property-lines.el index c95041c9a..737d2af0d 100644 --- a/tests/test-calendar-sync--get-all-property-lines.el +++ b/tests/test-calendar-sync--get-all-property-lines.el @@ -57,5 +57,23 @@ "Test empty event string returns nil." (should (null (calendar-sync--get-all-property-lines "" "ATTENDEE")))) +;;; Boundary Cases — position advancement + +(ert-deftest test-calendar-sync--get-all-property-lines-property-at-end-no-newline () + "Boundary: a match at end of string with no trailing newline still returns it. +Exercises the end-equals-length branch of position advancement." + (let ((result (calendar-sync--get-all-property-lines + "ATTENDEE:foo@example.com" "ATTENDEE"))) + (should (= 1 (length result))) + (should (string-match-p "foo@example.com" (car result))))) + +(ert-deftest test-calendar-sync--get-all-property-lines-second-match-after-continuation () + "Boundary: a first match with a continuation does not hide the second match." + (let ((result (calendar-sync--get-all-property-lines + "ATTENDEE:a\n more\nATTENDEE:b\nSUMMARY:x" "ATTENDEE"))) + (should (= 2 (length result))) + (should (string-match-p "more" (nth 0 result))) + (should (string-match-p "ATTENDEE:b" (nth 1 result))))) + (provide 'test-calendar-sync--get-all-property-lines) ;;; test-calendar-sync--get-all-property-lines.el ends here diff --git a/tests/test-calendar-sync--parse-exception-event.el b/tests/test-calendar-sync--parse-exception-event.el new file mode 100644 index 000000000..1935d3ebb --- /dev/null +++ b/tests/test-calendar-sync--parse-exception-event.el @@ -0,0 +1,64 @@ +;;; test-calendar-sync--parse-exception-event.el --- Tests for one-event exception parsing -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for calendar-sync--parse-exception-event, the per-VEVENT half of +;; calendar-sync--collect-recurrence-exceptions: it turns a single RECURRENCE-ID +;; override VEVENT into an exception plist (or nil). One function per file. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "." (file-name-directory load-file-name))) +(add-to-list 'load-path (expand-file-name "../modules" (file-name-directory load-file-name))) +(require 'testutil-calendar-sync) +(require 'calendar-sync) + +(defun test-cs-parse-exc--override-event (start end) + "Return a RECURRENCE-ID override VEVENT string for START..END." + (concat "BEGIN:VEVENT\n" + "UID:override@google.com\n" + "RECURRENCE-ID:20260203T090000Z\n" + "SUMMARY:Rescheduled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "DTEND:" (test-calendar-sync-ics-datetime end) "\n" + "END:VEVENT")) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--parse-exception-event-normal-returns-plist () + "Normal: a RECURRENCE-ID override parses into a plist with its overridden times." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (plist (calendar-sync--parse-exception-event + (test-cs-parse-exc--override-event start end)))) + (should plist) + (should (plist-get plist :recurrence-id)) + (should (equal "20260203T090000Z" (plist-get plist :recurrence-id-raw))) + (should (plist-get plist :start)) + (should (plist-get plist :end)) + (should (equal "Rescheduled Meeting" (plist-get plist :summary))))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--parse-exception-event-boundary-no-recurrence-id () + "Boundary: a VEVENT with no RECURRENCE-ID is not an override and returns nil." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (event (test-calendar-sync-make-vevent "Regular Event" start end))) + (should-not (calendar-sync--parse-exception-event event)))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--parse-exception-event-error-unparseable-times () + "Error: a RECURRENCE-ID override whose times do not parse returns nil rather +than a half-built plist." + (let ((event (concat "BEGIN:VEVENT\n" + "UID:broken@google.com\n" + "RECURRENCE-ID:not-a-timestamp\n" + "SUMMARY:Broken Override\n" + "DTSTART:also-garbage\n" + "END:VEVENT"))) + (should-not (calendar-sync--parse-exception-event event)))) + +(provide 'test-calendar-sync--parse-exception-event) +;;; test-calendar-sync--parse-exception-event.el ends here diff --git a/tests/test-calendar-sync--parse-timestamp.el b/tests/test-calendar-sync--parse-timestamp.el index d05540f7c..6a56ba9e2 100644 --- a/tests/test-calendar-sync--parse-timestamp.el +++ b/tests/test-calendar-sync--parse-timestamp.el @@ -55,5 +55,28 @@ "Truncated datetime returns nil." (should (null (calendar-sync--parse-timestamp "2026031")))) +;;; Boundary / Error — second capture, TZID fallback, leap day + +(ert-deftest test-calendar-sync--parse-timestamp-utc-passes-nonzero-seconds () + "Boundary: the seconds field is captured and passed to the UTC converter." + (cl-letf (((symbol-function 'calendar-sync--convert-utc-to-local) + (lambda (y mo d h mi s) (list 'utc y mo d h mi s)))) + (should (equal (calendar-sync--parse-timestamp "20260315T180045Z") + '(utc 2026 3 15 18 0 45))))) + +(ert-deftest test-calendar-sync--parse-timestamp-tzid-fallback-on-failure () + "Error: when TZID conversion fails, the raw 5-tuple is returned." + (cl-letf (((symbol-function 'calendar-sync--convert-tz-to-local) + (lambda (&rest _) nil))) + (should (equal (calendar-sync--parse-timestamp "20260315T180000" "Fake/Zone") + '(2026 3 15 18 0))))) + +(ert-deftest test-calendar-sync--parse-timestamp-leap-day-components () + "Boundary: a valid leap day (2024-02-29) is parsed into its components." + (cl-letf (((symbol-function 'calendar-sync--convert-utc-to-local) + (lambda (y mo d h mi s) (list y mo d h mi s)))) + (should (equal (calendar-sync--parse-timestamp "20240229T120000Z") + '(2024 2 29 12 0 0))))) + (provide 'test-calendar-sync--parse-timestamp) ;;; test-calendar-sync--parse-timestamp.el ends here diff --git a/tests/test-calendar-sync--robustness.el b/tests/test-calendar-sync--robustness.el new file mode 100644 index 000000000..2c044b013 --- /dev/null +++ b/tests/test-calendar-sync--robustness.el @@ -0,0 +1,70 @@ +;;; test-calendar-sync--robustness.el --- Tests for sync robustness fixes -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for two robustness fixes: +;; - calendar-sync--parse-ics distinguishes a healthy zero-event calendar +;; (a real iCalendar with no in-window events -> non-nil header) from +;; garbage (no BEGIN:VCALENDAR -> nil), so a near-empty calendar no longer +;; reports "parse failed". +;; - calendar-sync--write-file writes atomically (temp file + rename), so a +;; reader never sees a half-written calendar and no temp file is left behind. +;; (The curl --fail change is in the make-process command list and is exercised +;; against the live feed, not unit-tested here.) + +;;; Code: + +(require 'ert) +(require 'calendar-sync) + +;;; calendar-sync--parse-ics: zero-event vs garbage + +(ert-deftest test-calendar-sync--parse-ics-valid-zero-events-non-nil () + "Normal: a real iCalendar with no in-window events returns a non-nil empty +calendar, not a parse failure." + (let ((result (calendar-sync--parse-ics "BEGIN:VCALENDAR\nVERSION:2.0\nEND:VCALENDAR\n"))) + (should result) + (should (string-match-p "Calendar Events" result)))) + +(ert-deftest test-calendar-sync--parse-ics-garbage-nil () + "Error: non-iCalendar content (no BEGIN:VCALENDAR, e.g. an HTML error page) +returns nil -- a genuine failure." + (should-not (calendar-sync--parse-ics "HTTP 404 Not Found\n<html><body>error</body></html>"))) + +;;; calendar-sync--write-file: atomic + +(ert-deftest test-calendar-sync--write-file-writes-content () + "Normal: the content lands in the target file." + (let* ((dir (make-temp-file "cal-sync-test-" t)) + (file (expand-file-name "agenda.org" dir))) + (unwind-protect + (progn + (calendar-sync--write-file "# Calendar Events\n\nhello\n" file) + (should (equal "# Calendar Events\n\nhello\n" + (with-temp-buffer (insert-file-contents file) + (buffer-string))))) + (delete-directory dir t)))) + +(ert-deftest test-calendar-sync--write-file-leaves-no-temp () + "Boundary: the temp file is renamed into place, not left in the directory." + (let* ((dir (make-temp-file "cal-sync-test-" t)) + (file (expand-file-name "agenda.org" dir))) + (unwind-protect + (progn + (calendar-sync--write-file "x" file) + ;; only the target file remains -- no leftover .calendar-sync-* temp + (should (equal '("agenda.org") + (directory-files dir nil "\\`[^.]")))) + (delete-directory dir t)))) + +(ert-deftest test-calendar-sync--write-file-creates-parent-dir () + "Boundary: a missing parent directory is created." + (let* ((root (make-temp-file "cal-sync-test-" t)) + (file (expand-file-name "sub/nested/agenda.org" root))) + (unwind-protect + (progn + (calendar-sync--write-file "y" file) + (should (file-exists-p file))) + (delete-directory root t)))) + +(provide 'test-calendar-sync--robustness) +;;; test-calendar-sync--robustness.el ends here diff --git a/tests/test-calendar-sync.el b/tests/test-calendar-sync.el index b912c1328..f562cfc61 100644 --- a/tests/test-calendar-sync.el +++ b/tests/test-calendar-sync.el @@ -471,11 +471,14 @@ Earlier events should appear first in the output." (should (string-match-p "\\* Event 1" org-content)) (should (string-match-p "\\* Event 2" org-content)))) -(ert-deftest test-calendar-sync--parse-ics-boundary-empty-calendar-returns-nil () - "Test parsing empty calendar (no events)." +(ert-deftest test-calendar-sync--parse-ics-boundary-empty-calendar-returns-header () + "A valid but empty iCalendar (no events) is a healthy zero-event calendar: +it returns a non-nil header so the sync reports success, not a parse failure. +Garbage with no BEGIN:VCALENDAR still returns nil (covered elsewhere)." (let* ((ics "BEGIN:VCALENDAR\nVERSION:2.0\nEND:VCALENDAR") (org-content (calendar-sync--parse-ics ics))) - (should (null org-content)))) + (should org-content) + (should (string-match-p "Calendar Events" org-content)))) (ert-deftest test-calendar-sync--parse-ics-error-malformed-ics-returns-nil () "Test that malformed .ics returns nil and sets error." @@ -693,5 +696,22 @@ Valid events should be parsed, invalid ones skipped." (should retrieved) (should (eq 'ok (plist-get retrieved :status)))))) +;;; Tests: calendar-sync--parse-ics — boundary inputs + +(ert-deftest test-calendar-sync--parse-ics-nil-content-returns-nil () + "Boundary: nil ICS content is handled gracefully and returns nil." + (should (null (calendar-sync--parse-ics nil)))) + +(ert-deftest test-calendar-sync--parse-ics-drops-out-of-range-event () + "Boundary: a non-recurring event outside the date range is dropped." + (let* ((far (test-calendar-sync-make-vevent + "OutOfRangeEvent" + (test-calendar-sync-time-days-from-now 3650 10 0) + (test-calendar-sync-time-days-from-now 3650 11 0))) + (ics (test-calendar-sync-make-ics far)) + (org-content (calendar-sync--parse-ics ics))) + (should-not (and org-content + (string-match-p "OutOfRangeEvent" org-content))))) + (provide 'test-calendar-sync) ;;; test-calendar-sync.el ends here diff --git a/tests/test-calibredb-epub-config.el b/tests/test-calibredb-epub-config.el index 48d638358..cb3a9ba74 100644 --- a/tests/test-calibredb-epub-config.el +++ b/tests/test-calibredb-epub-config.el @@ -29,8 +29,8 @@ `(with-temp-buffer (setq-local major-mode 'nov-mode) (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 200)) - ((symbol-function 'window-margins) (lambda (_) '(nil . nil))) + ((symbol-function 'window-body-width) (lambda (&rest _) 200)) + ((symbol-function 'window-margins) (lambda (&rest _) '(nil . nil))) ((symbol-function 'set-window-margins) (lambda (&rest _) nil)) ((symbol-function 'set-window-fringes) (lambda (&rest _) nil))) ,@body))) @@ -73,8 +73,8 @@ below 50% of the usable columns." (let ((cj/nov-margin-percent 25) (cj/nov-min-text-width 40)) (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 120)) - ((symbol-function 'window-margins) (lambda (_) '(nil . nil)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 120)) + ((symbol-function 'window-margins) (lambda (&rest _) '(nil . nil)))) (should (= 60 (cj/nov--text-width-for-window)))))) (ert-deftest test-calibredb-epub-nov-text-width-for-window-idempotent () @@ -85,8 +85,8 @@ this, every layout pass would shave the column by another margin fraction." (let ((cj/nov-margin-percent 25) (cj/nov-min-text-width 40)) (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 60)) - ((symbol-function 'window-margins) (lambda (_) '(30 . 30)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 60)) + ((symbol-function 'window-margins) (lambda (&rest _) '(30 . 30)))) (should (= 60 (cj/nov--text-width-for-window)))))) (ert-deftest test-calibredb-epub-nov-text-width-for-window-no-window () @@ -214,15 +214,15 @@ so nov's `shr' fills the text itself rather than relying on visual-fill-column." (ert-deftest test-calibredb-epub-nov-natural-window-width-no-margins () "Normal: with no margins set, the natural width equals `window-body-width'." (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 100)) - ((symbol-function 'window-margins) (lambda (_) '(nil . nil)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 100)) + ((symbol-function 'window-margins) (lambda (&rest _) '(nil . nil)))) (should (= 100 (cj/nov--natural-window-width))))) (ert-deftest test-calibredb-epub-nov-natural-window-width-adds-margins () "Boundary: with margins set, the natural width adds them back to the body." (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'win)) - ((symbol-function 'window-body-width) (lambda (_) 60)) - ((symbol-function 'window-margins) (lambda (_) '(20 . 20)))) + ((symbol-function 'window-body-width) (lambda (&rest _) 60)) + ((symbol-function 'window-margins) (lambda (&rest _) '(20 . 20)))) (should (= 100 (cj/nov--natural-window-width))))) (ert-deftest test-calibredb-epub-nov-natural-window-width-no-window-fallback () diff --git a/tests/test-chrono-tools--sound-helpers.el b/tests/test-chrono-tools--sound-helpers.el new file mode 100644 index 000000000..08f71f9bb --- /dev/null +++ b/tests/test-chrono-tools--sound-helpers.el @@ -0,0 +1,54 @@ +;;; test-chrono-tools--sound-helpers.el --- Tests for the tmr sound-file helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/tmr--current-sound-name and cj/tmr--apply-sound-file were extracted from +;; the deeply-nested cj/tmr-select-sound-file so the "what's the current sound" +;; and "set the chosen sound" steps are unit-testable apart from the +;; completing-read UI. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'chrono-tools) + +(defvar tmr-sound-file) +(defvar sounds-dir) +(defvar notification-sound) + +(ert-deftest test-chrono-current-sound-name-existing () + "Normal: returns the basename when the current sound file exists." + (let* ((f (make-temp-file "tmr-sound" nil ".wav")) + (tmr-sound-file f)) + (unwind-protect + (should (equal (cj/tmr--current-sound-name) (file-name-nondirectory f))) + (delete-file f)))) + +(ert-deftest test-chrono-current-sound-name-missing-or-nil () + "Boundary: a missing file or nil yields nil." + (let ((tmr-sound-file "/no/such/file.wav")) + (should (null (cj/tmr--current-sound-name)))) + (let ((tmr-sound-file nil)) + (should (null (cj/tmr--current-sound-name))))) + +(ert-deftest test-chrono-apply-sound-file-sets-and-messages () + "Normal: sets tmr-sound-file under sounds-dir and reports the choice." + (let ((sounds-dir "/snd") + (notification-sound "/snd/default.wav") + (tmr-sound-file nil)) + (let ((msg (cj/tmr--apply-sound-file "chime.wav"))) + (should (equal tmr-sound-file "/snd/chime.wav")) + (should (string-match-p "Timer sound set to: chime.wav" msg))))) + +(ert-deftest test-chrono-apply-sound-file-default-branch () + "Boundary: choosing the notification sound reports it as the default." + (let ((sounds-dir "/snd") + (notification-sound "/snd/default.wav") + (tmr-sound-file nil)) + (let ((msg (cj/tmr--apply-sound-file "default.wav"))) + (should (equal tmr-sound-file "/snd/default.wav")) + (should (string-match-p "default: default.wav" msg))))) + +(provide 'test-chrono-tools--sound-helpers) +;;; test-chrono-tools--sound-helpers.el ends here diff --git a/tests/test-cj-cache-lib.el b/tests/test-cj-cache-lib.el index aeb329dda..7de7edb8c 100644 --- a/tests/test-cj-cache-lib.el +++ b/tests/test-cj-cache-lib.el @@ -4,7 +4,7 @@ ;; Unit tests for the TTL+building cache helper. Covers cache-make / ;; cache-valid-p / cache-value-or-rebuild / cache-building-p / ;; cache-invalidate against the contract in -;; docs/design/cache-helper-design.org. +;; docs/specs/cache-helper-design-spec-implemented.org. ;;; Code: diff --git a/tests/test-cj-window-geometry-lib.el b/tests/test-cj-window-geometry-lib.el index 05ed95950..d32a48a92 100644 --- a/tests/test-cj-window-geometry-lib.el +++ b/tests/test-cj-window-geometry-lib.el @@ -2,7 +2,7 @@ ;;; Commentary: ;; Tests the pure helpers in `cj-window-geometry-lib.el': -;; `cj/window-direction', `cj/window-body-size', +;; `cj/window-direction', `cj/window-replay-size', ;; `cj/cardinal-to-edge-direction', and `cj/window-at-edge'. ;;; Code: @@ -52,30 +52,32 @@ (delete-other-windows) (should (eq (cj/window-direction (selected-window) 'below) 'below)))) -(ert-deftest test-cj-window-geometry--body-size-right-returns-body-cols () +(ert-deftest test-cj-window-geometry--replay-size-right-returns-body-cols () "Normal: right window with direction='right -> body-width in cols." (save-window-excursion (delete-other-windows) (let ((right (split-window (selected-window) nil 'right))) - (should (= (cj/window-body-size right 'right) + (should (= (cj/window-replay-size right 'right) (window-body-width right)))))) -(ert-deftest test-cj-window-geometry--body-size-below-returns-body-lines () - "Normal: below window with direction='below -> body-height in lines." +(ert-deftest test-cj-window-geometry--replay-size-below-returns-total-lines () + "Normal: below window with direction='below -> total-height in lines. +The vertical axis captures total-height (not body-height) so the capture/ +replay round-trip is immune to the mode line's pixel height." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below))) - (should (= (cj/window-body-size below 'below) - (window-body-height below)))))) + (should (= (cj/window-replay-size below 'below) + (window-total-height below)))))) -(ert-deftest test-cj-window-geometry--body-size-narrow-window () +(ert-deftest test-cj-window-geometry--replay-size-narrow-window () "Normal: deliberately narrow right window -> matching body cols." (save-window-excursion (delete-other-windows) (let* ((frame-w (frame-width)) (target-cols (/ frame-w 4)) (right (split-window (selected-window) (- target-cols) 'right))) - (should (= (cj/window-body-size right 'right) + (should (= (cj/window-replay-size right 'right) (window-body-width right)))))) (ert-deftest test-cj-window-geometry--cardinal-to-edge-right () @@ -197,5 +199,52 @@ window forms the full-height right half -> nil." (should (null (cj/window-size-fraction nil 40))) (should (null (cj/window-size-fraction 20 nil)))) +;; ----------------------------- preferred-dock-direction ----------------------------- + +(ert-deftest test-cj-window-geometry-dock-wide-frame-is-right () + "Normal: a frame wide enough for both panes to clear 80 docks right." + (should (eq (cj/preferred-dock-direction 200 0.5) 'right))) + +(ert-deftest test-cj-window-geometry-dock-narrow-frame-is-below () + "Normal: an 0.5 split on a 138-col frame leaves ~68-col panes -> below." + (should (eq (cj/preferred-dock-direction 138 0.5) 'below))) + +(ert-deftest test-cj-window-geometry-dock-boundary-exactly-min-is-right () + "Boundary: when the narrower pane lands exactly on 80, dock right." + ;; 161 cols, 0.5: panel 80, main 161-80-1 = 80, narrower 80 -> right. + (should (eq (cj/preferred-dock-direction 161 0.5) 'right))) + +(ert-deftest test-cj-window-geometry-dock-boundary-one-under-min-is-below () + "Boundary: one column short of the floor stacks instead." + ;; 160 cols, 0.5: panel 80, main 160-80-1 = 79, narrower 79 -> below. + (should (eq (cj/preferred-dock-direction 160 0.5) 'below))) + +(ert-deftest test-cj-window-geometry-dock-narrow-panel-fraction-governs () + "Normal: a slim panel fraction makes the panel the narrower pane." + ;; 200 cols, 0.3: panel 60 < 80 -> below, even though main (139) is wide. + (should (eq (cj/preferred-dock-direction 200 0.3) 'below)) + ;; 300 cols, 0.3: panel 90, main 209 -> right. + (should (eq (cj/preferred-dock-direction 300 0.3) 'right))) + +(ert-deftest test-cj-window-geometry-dock-honors-explicit-min-cols () + "Boundary: an explicit MIN-COLS overrides the default floor." + ;; 138 cols, 0.5 -> ~68-col panes: passes a 60-floor, fails the 80-default. + (should (eq (cj/preferred-dock-direction 138 0.5 60) 'right)) + (should (eq (cj/preferred-dock-direction 138 0.5 80) 'below))) + +(ert-deftest test-cj-window-geometry-dock-honors-custom-default-var () + "Boundary: the default floor reads `cj/window-dock-min-columns'." + (let ((cj/window-dock-min-columns 30)) + (should (eq (cj/preferred-dock-direction 138 0.5) 'right)))) + +(ert-deftest test-cj-window-geometry-dock-degenerate-input-is-below () + "Error: non-positive cols or out-of-range fraction stacks (safe fallback)." + (should (eq (cj/preferred-dock-direction 0 0.5) 'below)) + (should (eq (cj/preferred-dock-direction -10 0.5) 'below)) + (should (eq (cj/preferred-dock-direction 200 0) 'below)) + (should (eq (cj/preferred-dock-direction 200 1) 'below)) + (should (eq (cj/preferred-dock-direction nil 0.5) 'below)) + (should (eq (cj/preferred-dock-direction 200 nil) 'below))) + (provide 'test-cj-window-geometry-lib) ;;; test-cj-window-geometry-lib.el ends here diff --git a/tests/test-cj-window-toggle-lib.el b/tests/test-cj-window-toggle-lib.el index 0762e255c..5edd06e96 100644 --- a/tests/test-cj-window-toggle-lib.el +++ b/tests/test-cj-window-toggle-lib.el @@ -36,7 +36,9 @@ (window-body-width right)))))) (ert-deftest test-cj-window-toggle-capture-records-below-split () - "Normal: below-split window writes direction=below and integer body-lines." + "Normal: below-split window writes direction=below and integer total-lines. +The vertical axis captures total-height, not body-height, so the round-trip +is immune to the mode line's pixel height (see `cj/window-replay-size')." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below)) @@ -49,7 +51,7 @@ (should (eq test-cj-window-toggle--last-direction 'below)) (should (integerp test-cj-window-toggle--last-size)) (should (= test-cj-window-toggle--last-size - (window-body-height below)))))) + (window-total-height below)))))) (ert-deftest test-cj-window-toggle-capture-falls-back-to-default-direction () "Boundary: window filling the frame uses the supplied default direction." @@ -156,7 +158,9 @@ transfer; clearing it lets the consumer's default size apply." (should (eq (cdr (assq 'inhibit-same-window received-alist)) t)))) (ert-deftest test-cj-window-toggle-display-saved-maps-below-to-bottom () - "Normal: saved below + integer size -> bottom edge, body-lines cons." + "Normal: saved below + integer size -> bottom edge, plain total-line count. +The height axis replays a total-line integer (not a body-lines cons) so the +round-trip is immune to the mode line's pixel height." (let (received-alist (test-cj-window-toggle--last-direction 'below) (test-cj-window-toggle--last-size 12)) @@ -169,8 +173,7 @@ transfer; clearing it lets the consumer's default size apply." 'test-cj-window-toggle--last-size 0.7)) (should (eq (cdr (assq 'direction received-alist)) 'bottom)) - (should (equal (cdr (assq 'window-height received-alist)) - '(body-lines . 12))) + (should (equal (cdr (assq 'window-height received-alist)) 12)) (should-not (assq 'window-width received-alist)))) (ert-deftest test-cj-window-toggle-display-saved-maps-right-to-rightmost () diff --git a/tests/test-config-utilities--compile-this-elisp-buffer.el b/tests/test-config-utilities--compile-this-elisp-buffer.el index fb5e288a1..a06440abb 100644 --- a/tests/test-config-utilities--compile-this-elisp-buffer.el +++ b/tests/test-config-utilities--compile-this-elisp-buffer.el @@ -21,7 +21,7 @@ effects." (declare (indent 1) (debug t)) `(with-temp-buffer (setq buffer-file-name ,path) - (cl-letf (((symbol-function 'save-buffer) (lambda () nil))) + (cl-letf (((symbol-function 'save-buffer) (lambda (&rest _) nil))) ,@body))) (ert-deftest test-config-utilities-compile-buffer-not-elisp-raises () @@ -47,7 +47,7 @@ effects." ((symbol-function 'native-compile) (lambda (_) (error "should not call sync native-compile"))) ((symbol-function 'byte-compile-file) - (lambda (_) (error "should not call byte-compile-file")))) + (lambda (&rest _) (error "should not call byte-compile-file")))) (cj/compile-this-elisp-buffer) (should (equal called-with "/tmp/some.el")))))) @@ -60,7 +60,7 @@ effects." ((symbol-function 'native-compile) (lambda (file) (setq called-with file))) ((symbol-function 'byte-compile-file) - (lambda (_) (error "should not call byte-compile-file")))) + (lambda (&rest _) (error "should not call byte-compile-file")))) (cj/compile-this-elisp-buffer) (should (equal called-with "/tmp/some.el")))))) @@ -71,7 +71,7 @@ effects." (cl-letf (((symbol-function 'fboundp) (lambda (sym) (eq sym 'byte-compile-file))) ((symbol-function 'byte-compile-file) - (lambda (file) (setq called-with file) "/tmp/some.elc"))) + (lambda (file &rest _) (setq called-with file) "/tmp/some.elc"))) (cj/compile-this-elisp-buffer) (should (equal called-with "/tmp/some.el")))))) diff --git a/tests/test-coverage-core--changed-lines.el b/tests/test-coverage-core--changed-lines.el index f271fde15..0662594b4 100644 --- a/tests/test-coverage-core--changed-lines.el +++ b/tests/test-coverage-core--changed-lines.el @@ -227,5 +227,106 @@ Binary files a/image.png and b/image.png differ (should-error (cj/--coverage-changed-lines 'bogus-scope) :type 'user-error)) +;;; Boundary cases — parser, /dev/null and orphan hunks + +(ert-deftest test-coverage-parse-diff-dev-null-resets-current-file () + "Boundary: a \"+++ /dev/null\" target resets state so a following hunk is +not misattributed to the previous file." + (let* ((input (concat "diff --git a/keep.el b/keep.el\n" + "--- a/keep.el\n" + "+++ b/keep.el\n" + "@@ -1,0 +1,2 @@\n" + "+k1\n+k2\n" + "diff --git a/gone.el b/gone.el\n" + "--- a/gone.el\n" + "+++ /dev/null\n" + "@@ -1,0 +5,2 @@\n" + "+orphan1\n+orphan2\n")) + (result (cj/--coverage-parse-diff-output input)) + (keep (gethash "keep.el" result))) + (should (= 1 (hash-table-count result))) ; gone.el never recorded + (should (= 2 (hash-table-count keep))) + (should (gethash 1 keep)) + (should (gethash 2 keep)) + (should-not (gethash 5 keep)) ; not misattributed + (should-not (gethash 6 keep)))) + +(ert-deftest test-coverage-parse-diff-hunk-before-any-file-marker () + "Boundary: a hunk header before any file marker is ignored, not crashed on." + (let* ((input (concat "@@ -1,0 +1,2 @@\n" + "+orphan1\n+orphan2\n" + "diff --git a/real.el b/real.el\n" + "--- a/real.el\n" + "+++ b/real.el\n" + "@@ -1,0 +1,1 @@\n" + "+r1\n")) + (result (cj/--coverage-parse-diff-output input)) + (real (gethash "real.el" result))) + (should (= 1 (hash-table-count result))) + (should (= 1 (hash-table-count real))) + (should (gethash 1 real)))) + +;;; merge-base (stubbed git invocation) + +(ert-deftest test-coverage-git-merge-base-returns-trimmed-sha () + "Normal: a SHA with trailing newline is trimmed and returned." + (cl-letf (((symbol-function 'process-file) + (lambda (_program _infile destination _display &rest _args) + (with-current-buffer destination (insert "abc123\n")) + 0))) + (should (equal (cj/--coverage-git-merge-base "main") "abc123")))) + +(ert-deftest test-coverage-git-merge-base-empty-output-errors () + "Error: empty merge-base output signals user-error (no common commit)." + (cl-letf (((symbol-function 'process-file) + (lambda (_program _infile destination _display &rest _args) + (with-current-buffer destination (insert "")) + 0))) + (should-error (cj/--coverage-git-merge-base "main") :type 'user-error))) + +(ert-deftest test-coverage-git-merge-base-whitespace-output-errors () + "Error: whitespace-only output trims to empty and signals user-error." + (cl-letf (((symbol-function 'process-file) + (lambda (_program _infile destination _display &rest _args) + (with-current-buffer destination (insert " \n")) + 0))) + (should-error (cj/--coverage-git-merge-base "main") :type 'user-error))) + +;;; changed-lines — remaining scopes (stubbed git invocation) + +(ert-deftest test-coverage-changed-lines-staged-stubbed () + "Normal: staged scope invokes git diff --cached via argv." + (let (seen-calls) + (cl-letf (((symbol-function 'process-file) + (lambda (program _infile destination _display &rest args) + (push (cons program args) seen-calls) + (with-current-buffer destination + (insert test-coverage-diff--simple-single-file)) + 0))) + (let ((result (cj/--coverage-changed-lines 'staged))) + (should (equal (nreverse seen-calls) + '(("git" "diff" "--cached" "--unified=0")))) + (should (= 3 (hash-table-count (gethash "foo.el" result)))))))) + +(ert-deftest test-coverage-changed-lines-branch-vs-main-stubbed () + "Normal: branch-vs-main computes merge-base against main, then diffs." + (let (seen-calls) + (cl-letf (((symbol-function 'process-file) + (lambda (program _infile destination _display &rest args) + (push (cons program args) seen-calls) + (with-current-buffer destination + (insert + (pcase args + (`("merge-base" "HEAD" "main") "abc123\n") + (`("diff" "abc123..HEAD" "--unified=0") + test-coverage-diff--simple-single-file) + (_ "")))) + 0))) + (let ((result (cj/--coverage-changed-lines 'branch-vs-main))) + (should (equal (nreverse seen-calls) + '(("git" "merge-base" "HEAD" "main") + ("git" "diff" "abc123..HEAD" "--unified=0")))) + (should (= 3 (hash-table-count (gethash "foo.el" result)))))))) + (provide 'test-coverage-core--changed-lines) ;;; test-coverage-core--changed-lines.el ends here diff --git a/tests/test-coverage-core--project-root.el b/tests/test-coverage-core--project-root.el new file mode 100644 index 000000000..9d596217a --- /dev/null +++ b/tests/test-coverage-core--project-root.el @@ -0,0 +1,37 @@ +;;; test-coverage-core--project-root.el --- Tests for cj/--coverage-project-root -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `cj/--coverage-project-root' in coverage-core.el — returns the +;; projectile project root when available, else `default-directory'. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'coverage-core) + +;;; Normal Cases + +(ert-deftest test-coverage-project-root-uses-projectile-when-available () + "Normal: with projectile available and in a project, returns its root." + (cl-letf (((symbol-function 'projectile-project-root) + (lambda () "/home/u/proj/"))) + (should (equal (cj/--coverage-project-root) "/home/u/proj/")))) + +;;; Boundary Cases + +(ert-deftest test-coverage-project-root-falls-back-when-projectile-absent () + "Boundary: with no projectile function, falls back to default-directory." + (cl-letf (((symbol-function 'projectile-project-root) nil)) + (let ((default-directory "/fallback/dir/")) + (should (equal (cj/--coverage-project-root) "/fallback/dir/"))))) + +(ert-deftest test-coverage-project-root-falls-back-when-not-in-project () + "Boundary: projectile present but returns nil (not in a project) falls back." + (cl-letf (((symbol-function 'projectile-project-root) (lambda () nil))) + (let ((default-directory "/fallback/dir/")) + (should (equal (cj/--coverage-project-root) "/fallback/dir/"))))) + +(provide 'test-coverage-core--project-root) +;;; test-coverage-core--project-root.el ends here diff --git a/tests/test-coverage-core--relativize-keys.el b/tests/test-coverage-core--relativize-keys.el new file mode 100644 index 000000000..82031cd15 --- /dev/null +++ b/tests/test-coverage-core--relativize-keys.el @@ -0,0 +1,123 @@ +;;; test-coverage-core--relativize-keys.el --- Tests for path-key normalization -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit + integration tests for `cj/--coverage-relativize-keys', the helper +;; that normalizes a file-path-keyed coverage table to repo-relative paths. +;; +;; The bug it fixes: `cj/--coverage-parse-simplecov' returns ABSOLUTE path +;; keys (simplecov/undercover emit absolute source paths), while +;; `cj/--coverage-parse-diff-output' returns repo-RELATIVE keys (git's +;; "+++ b/<path>"). `cj/--coverage-intersect' joins the two by exact string +;; key, so for the diff-aware scopes every changed file was classified +;; ":tracked nil" — zero matches ever. Normalizing both tables to +;; repo-relative before the intersect makes the join work. +;; +;; The integration test drives the real parsers (a simplecov JSON fixture +;; with an absolute key + a git-diff string with the relative key) through +;; relativize + intersect, and asserts the file is tracked with the right +;; covered/uncovered split — the end-to-end reproduction of the bug. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'coverage-core) + +(defun test-coverage-relativize--hash-of-lines (pairs) + "Build a file → line-set hash table from PAIRS. +Each pair is (FILE . (LINES...)); LINES becomes a hash-table of line → t." + (let ((result (make-hash-table :test 'equal))) + (dolist (pair pairs) + (let ((lines (make-hash-table :test 'eql))) + (dolist (line (cdr pair)) + (puthash line t lines)) + (puthash (car pair) lines result))) + result)) + +;;; Normal cases + +(ert-deftest test-coverage-relativize-absolute-key-made-relative () + "Normal: an absolute key is relativized against ROOT." + (let* ((table (test-coverage-relativize--hash-of-lines + '(("/home/u/.emacs.d/modules/foo.el" 10 11)))) + (out (cj/--coverage-relativize-keys table "/home/u/.emacs.d"))) + (should (gethash "modules/foo.el" out)) + (should (null (gethash "/home/u/.emacs.d/modules/foo.el" out))))) + +(ert-deftest test-coverage-relativize-preserves-line-set () + "Normal: the line-set value travels unchanged to the new key." + (let* ((table (test-coverage-relativize--hash-of-lines + '(("/r/modules/foo.el" 4 8 15)))) + (out (cj/--coverage-relativize-keys table "/r")) + (lines (gethash "modules/foo.el" out))) + (should (hash-table-p lines)) + (should (gethash 4 lines)) + (should (gethash 8 lines)) + (should (gethash 15 lines)))) + +;;; Boundary cases + +(ert-deftest test-coverage-relativize-already-relative-unchanged () + "Boundary: an already-relative key is left as-is, not re-relativized." + (let* ((table (test-coverage-relativize--hash-of-lines + '(("modules/foo.el" 1 2)))) + (out (cj/--coverage-relativize-keys table "/home/u/.emacs.d"))) + (should (gethash "modules/foo.el" out)) + (should (= 1 (hash-table-count out))))) + +(ert-deftest test-coverage-relativize-empty-table () + "Boundary: an empty table yields an empty table." + (let ((out (cj/--coverage-relativize-keys (make-hash-table :test 'equal) "/r"))) + (should (hash-table-p out)) + (should (= 0 (hash-table-count out))))) + +;;; Error cases + +(ert-deftest test-coverage-relativize-nil-table-returns-empty () + "Error: a nil table returns an empty table rather than erroring." + (let ((out (cj/--coverage-relativize-keys nil "/r"))) + (should (hash-table-p out)) + (should (= 0 (hash-table-count out))))) + +;;; Integration — the real bug reproduction + +(ert-deftest test-coverage-integration-absolute-report-relative-diff-tracks () + "Integration: a simplecov report (absolute keys) and a git diff (relative +keys) for the same file intersect as TRACKED once both are relativized. +This is the diff-aware-scope bug: without normalization the file reads +\":tracked nil\"." + (let* ((root "/tmp/cov-root") + (abs-path (concat root "/modules/foo.el")) + (report (make-temp-file "cov-report-" nil ".json")) + (diff (concat + "diff --git a/modules/foo.el b/modules/foo.el\n" + "index 1111111..2222222 100644\n" + "--- a/modules/foo.el\n" + "+++ b/modules/foo.el\n" + "@@ -2,0 +2,3 @@\n" + "+line two\n" + "+line three\n" + "+line four\n"))) + (unwind-protect + (progn + ;; simplecov array: index1=null, 2=hit, 3=0-hits, 4=hit + ;; → covered lines {2, 4} + (with-temp-file report + (insert (format "{\"t\":{\"coverage\":{%S:[null,1,0,2]}}}" abs-path))) + (let* ((covered (cj/--coverage-relativize-keys + (cj/--coverage-parse-simplecov report) root)) + (changed (cj/--coverage-relativize-keys + (cj/--coverage-parse-diff-output diff) root)) + (records (cj/--coverage-intersect covered changed)) + (record (car records))) + (should (= 1 (length records))) + (should (equal "modules/foo.el" (plist-get record :path))) + (should (eq t (plist-get record :tracked))) + (should (equal '(2 3 4) (plist-get record :changed-lines))) + (should (equal '(2 4) (plist-get record :covered-lines))) + (should (equal '(3) (plist-get record :uncovered-lines))))) + (delete-file report)))) + +(provide 'test-coverage-core--relativize-keys) +;;; test-coverage-core--relativize-keys.el ends here diff --git a/tests/test-custom-buffer-file-keymap-bindings.el b/tests/test-custom-buffer-file-keymap-bindings.el new file mode 100644 index 000000000..ea9ceb263 --- /dev/null +++ b/tests/test-custom-buffer-file-keymap-bindings.el @@ -0,0 +1,30 @@ +;;; test-custom-buffer-file-keymap-bindings.el --- d/D bindings in the buffer-and-file keymap -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/buffer-and-file-map' should put the destructive op on the capital key and +;; the frequently-used op on the easy lowercase key: D = delete-buffer-and-file, +;; d = diff-buffer-with-file. Guards the swap against silently reverting. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) + +;; Stub dependencies before loading the module (mirrors the sibling tests). +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") +(provide 'ps-print) + +(require 'custom-buffer-file) + +(ert-deftest test-custom-buffer-file-keymap-diff-on-lowercase-d () + "Normal: lowercase d runs diff -- the frequently-used, non-destructive op." + (should (eq (keymap-lookup cj/buffer-and-file-map "d") #'cj/diff-buffer-with-file))) + +(ert-deftest test-custom-buffer-file-keymap-delete-on-capital-d () + "Normal: capital D runs delete -- the destructive op on the capital key." + (should (eq (keymap-lookup cj/buffer-and-file-map "D") #'cj/delete-buffer-and-file))) + +(provide 'test-custom-buffer-file-keymap-bindings) +;;; test-custom-buffer-file-keymap-bindings.el ends here diff --git a/tests/test-custom-buffer-file-print-diff-eww.el b/tests/test-custom-buffer-file-print-diff-eww.el index 9aa73cbee..56cc917e0 100644 --- a/tests/test-custom-buffer-file-print-diff-eww.el +++ b/tests/test-custom-buffer-file-print-diff-eww.el @@ -30,14 +30,14 @@ (let ((cj/print-spooler-command "lpr") (cj/print--spooler-cache nil)) (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lpr") "/usr/bin/lpr")))) + (lambda (cmd &rest _) (when (equal cmd "lpr") "/usr/bin/lpr")))) (should (equal (cj/print--resolve-spooler) "lpr"))))) (ert-deftest test-cbf-resolve-spooler-explicit-string-missing-errors () "Error: explicit string spooler not on PATH signals user-error." (let ((cj/print-spooler-command "notathing") (cj/print--spooler-cache nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/print--resolve-spooler) :type 'user-error)))) (ert-deftest test-cbf-resolve-spooler-auto-detects-lpr-first () @@ -45,7 +45,7 @@ (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache nil)) (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lpr") "/usr/bin/lpr")))) + (lambda (cmd &rest _) (when (equal cmd "lpr") "/usr/bin/lpr")))) (should (equal (cj/print--resolve-spooler) "lpr")) (should (equal cj/print--spooler-cache "lpr"))))) @@ -54,14 +54,14 @@ (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache nil)) (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lp") "/usr/bin/lp")))) + (lambda (cmd &rest _) (when (equal cmd "lp") "/usr/bin/lp")))) (should (equal (cj/print--resolve-spooler) "lp"))))) (ert-deftest test-cbf-resolve-spooler-auto-no-tool-errors () "Error: `auto' with neither lpr nor lp signals user-error." (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/print--resolve-spooler) :type 'user-error)))) (ert-deftest test-cbf-resolve-spooler-auto-returns-cached-value () @@ -69,7 +69,7 @@ (let ((cj/print-spooler-command 'auto) (cj/print--spooler-cache "cached-cmd")) (cl-letf (((symbol-function 'executable-find) - (lambda (_) (error "should not be called")))) + (lambda (_ &rest _) (error "should not be called")))) (should (equal (cj/print--resolve-spooler) "cached-cmd"))))) (ert-deftest test-cbf-resolve-spooler-invalid-value-errors () @@ -87,7 +87,7 @@ (with-temp-buffer (rename-buffer "*test-cbf-copy-name*" t) (cl-letf (((symbol-function 'kill-new) - (lambda (s) (setq killed s))) + (lambda (s &rest _) (setq killed s))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) diff --git a/tests/test-custom-comments-comment-heavy-box.el b/tests/test-custom-comments-comment-heavy-box.el index 94d4aaa5f..8acb9ff0b 100644 --- a/tests/test-custom-comments-comment-heavy-box.el +++ b/tests/test-custom-comments-comment-heavy-box.el @@ -64,8 +64,8 @@ Returns the buffer string for assertions." (should (string-match-p "^;; \\*" result)) ;; Middle line should contain centered text (should (string-match-p "Section Header" result)) - ;; Should have side borders - (should (string-match-p "^\\*.*\\*$" result)))) + ;; Interior side-border lines carry the comment prefix/suffix (not a bare *) + (should (string-match-p "^;; \\*.*\\* ;;$" result)))) (ert-deftest test-heavy-box-elisp-custom-decoration () "Should use custom decoration character." @@ -83,8 +83,8 @@ Returns the buffer string for assertions." (let ((result (test-heavy-box-at-column 0 ";;" "" "*" "" 70))) ;; Should still generate 5 lines (should (= 5 (length (split-string result "\n" t)))) - ;; Middle line should just have side borders and spaces - (should (string-match-p "^\\*.*\\*$" result)))) + ;; Middle line should just have side borders and spaces, comment-prefixed + (should (string-match-p "^;; \\*.*\\* ;;$" result)))) (ert-deftest test-heavy-box-elisp-at-column-0 () "Should work at column 0." diff --git a/tests/test-custom-datetime-all-methods.el b/tests/test-custom-datetime-all-methods.el index c9cfa41e2..62b421bdc 100644 --- a/tests/test-custom-datetime-all-methods.el +++ b/tests/test-custom-datetime-all-methods.el @@ -108,5 +108,19 @@ (cj/insert-sortable-date)) (should (string-prefix-p "before 2026-02-15" (buffer-string))))) +;;; Macro-generated commands stay interactive + +(ert-deftest test-custom-datetime-all-methods-are-interactive-commands () + "All six inserters generated by `cj/--define-datetime-inserter' are +interactive commands (so they keep working via M-x and the C-; d keymap)." + (dolist (cmd '(cj/insert-readable-date-time + cj/insert-sortable-date-time + cj/insert-sortable-time + cj/insert-readable-time + cj/insert-sortable-date + cj/insert-readable-date)) + (should (fboundp cmd)) + (should (commandp cmd)))) + (provide 'test-custom-datetime-all-methods) ;;; test-custom-datetime-all-methods.el ends here diff --git a/tests/test-custom-line-paragraph-duplicate-line-or-region.el b/tests/test-custom-line-paragraph-duplicate-line-or-region.el index bd82e00fa..84f5bc2df 100644 --- a/tests/test-custom-line-paragraph-duplicate-line-or-region.el +++ b/tests/test-custom-line-paragraph-duplicate-line-or-region.el @@ -447,5 +447,19 @@ (should (string-match-p "line\u000Cwith\u000Dcontrol\nline\u000Cwith\u000Dcontrol" (buffer-string)))) (test-duplicate-line-or-region-teardown))) +;;; Error Cases + +(ert-deftest test-duplicate-line-or-region-comment-without-syntax-errors () + "Error: requesting a comment in a mode with no comment syntax signals +user-error rather than producing malformed output." + (test-duplicate-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (fundamental-mode) ; no comment-start defined + (insert "line one") + (goto-char (point-min)) + (should-error (cj/duplicate-line-or-region t) :type 'user-error)) + (test-duplicate-line-or-region-teardown))) + (provide 'test-custom-line-paragraph-duplicate-line-or-region) ;;; test-custom-line-paragraph-duplicate-line-or-region.el ends here diff --git a/tests/test-custom-ordering--region-helpers.el b/tests/test-custom-ordering--region-helpers.el new file mode 100644 index 000000000..2ec747966 --- /dev/null +++ b/tests/test-custom-ordering--region-helpers.el @@ -0,0 +1,52 @@ +;;; test-custom-ordering--region-helpers.el --- Tests for the shared ordering region helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--ordering-validate-region and cj/--ordering-replace-region were extracted +;; from the seven pure ordering helpers (the copy-pasted start>end guard) and the +;; interactive ordering commands (the copy-pasted delete-region + insert tail). +;; The per-command behavior stays covered by the existing wrapper/transform +;; tests; these cover the extracted helpers directly. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'custom-ordering) + +;;; cj/--ordering-validate-region + +(ert-deftest test-custom-ordering-validate-region-accepts-ordered () + "Normal: start < end returns nil without signalling." + (should (null (cj/--ordering-validate-region 1 10)))) + +(ert-deftest test-custom-ordering-validate-region-accepts-equal () + "Boundary: start = end (empty region) is allowed." + (should (null (cj/--ordering-validate-region 5 5)))) + +(ert-deftest test-custom-ordering-validate-region-rejects-inverted () + "Error: start > end signals with both positions in the message." + (let ((err (should-error (cj/--ordering-validate-region 10 3) :type 'error))) + (should (string-match-p "10" (error-message-string err))) + (should (string-match-p "3" (error-message-string err))))) + +;;; cj/--ordering-replace-region + +(ert-deftest test-custom-ordering-replace-region-swaps-text () + "Normal: the region between START and END is replaced with INSERTION and +point is left at START." + (with-temp-buffer + (insert "AAAABBBB") + (cj/--ordering-replace-region 1 5 "xx") ; replace the first AAAA + (should (equal "xxBBBB" (buffer-string))) + (should (= (point) 3)))) ; START (1) + len("xx") + +(ert-deftest test-custom-ordering-replace-region-empty-insertion () + "Boundary: an empty INSERTION just deletes the region." + (with-temp-buffer + (insert "keepDROP") + (cj/--ordering-replace-region 5 9 "") ; drop "DROP" (positions 5-8) + (should (equal "keep" (buffer-string))))) + +(provide 'test-custom-ordering--region-helpers) +;;; test-custom-ordering--region-helpers.el ends here diff --git a/tests/test-custom-text-enclose--enclose-region-or-word.el b/tests/test-custom-text-enclose--enclose-region-or-word.el new file mode 100644 index 000000000..4075fb050 --- /dev/null +++ b/tests/test-custom-text-enclose--enclose-region-or-word.el @@ -0,0 +1,62 @@ +;;; test-custom-text-enclose--enclose-region-or-word.el --- Tests for the shared enclose dispatch -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--enclose-region-or-word is the dispatch+edit skeleton extracted from +;; cj/surround/wrap/unwrap-word-or-region (region target, else word at point, +;; else a no-target message). The three commands stay covered by +;; test-custom-text-enclose-public-wrappers.el; these cover the helper directly, +;; including the custom and default no-target messages. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'custom-text-enclose) + +(ert-deftest test-cte-enclose-region-target () + "Normal: an active region is the target; TRANSFORM is applied to it." + (with-temp-buffer + (let ((transient-mark-mode t)) + (insert "abc") + (goto-char (point-min)) + (push-mark (point) t t) + (goto-char (point-max)) + (cj/--enclose-region-or-word #'upcase)) + (should (equal (buffer-string) "ABC")) + (should (= (point) 4)))) ; after the inserted "ABC" (start 1 + 3) + +(ert-deftest test-cte-enclose-word-at-point-target () + "Normal: with no region, the word at point is the target." + (with-temp-buffer + (insert "foo bar") + (goto-char (point-min)) ; point on "foo" + (cj/--enclose-region-or-word (lambda (s) (concat "<" s ">"))) + (should (equal (buffer-string) "<foo> bar")))) + +(ert-deftest test-cte-enclose-no-target-default-message () + "Boundary: no region and no word => default message, buffer untouched." + (with-temp-buffer + (insert " ") ; whitespace, no word + (goto-char (point-min)) + (let ((msg nil)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) + (cj/--enclose-region-or-word #'upcase)) + (should (string-match-p "No word at point" msg)) + (should (equal (buffer-string) " "))))) + +(ert-deftest test-cte-enclose-no-target-custom-message () + "Boundary: a supplied NO-TARGET-MESSAGE overrides the default." + (with-temp-buffer + (insert " ") + (goto-char (point-min)) + (let ((msg nil)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) + (cj/--enclose-region-or-word #'upcase "custom no-target text")) + (should (equal msg "custom no-target text"))))) + +(provide 'test-custom-text-enclose--enclose-region-or-word) +;;; test-custom-text-enclose--enclose-region-or-word.el ends here diff --git a/tests/test-dashboard-config-font-lock.el b/tests/test-dashboard-config-font-lock.el new file mode 100644 index 000000000..d55909723 --- /dev/null +++ b/tests/test-dashboard-config-font-lock.el @@ -0,0 +1,35 @@ +;;; test-dashboard-config-font-lock.el --- dashboard-mode excluded from global font-lock -*- lexical-binding: t; -*- + +;;; Commentary: +;; `global-font-lock-mode' fontifies the *dashboard* buffer and strips the +;; manually-applied `face' text properties dashboard puts on the banner title +;; (`dashboard-banner-logo-title') and the section headings +;; (`dashboard-heading'), so they render in the default face instead of the +;; theme colors. dashboard-config excludes dashboard-mode from global +;; font-lock so those text-property faces survive. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) + +;; Stub package-level deps dashboard-config pulls transitively. +(unless (fboundp 'cj/kill-all-other-buffers-and-windows) + (defun cj/kill-all-other-buffers-and-windows () nil)) +(unless (fboundp 'cj/make-buffer-undead) + (defun cj/make-buffer-undead (_name) nil)) + +(require 'dashboard-config) + +(ert-deftest test-dashboard-config-excludes-dashboard-mode-from-global-font-lock () + "Normal: dashboard-mode is excluded from `font-lock-global-modes'. +Global font-lock must not run in the dashboard buffer, or it strips the +manual face text properties dashboard applies to the banner and headings." + (should (consp font-lock-global-modes)) + (should (eq (car font-lock-global-modes) 'not)) + (should (memq 'dashboard-mode (cdr font-lock-global-modes)))) + +(provide 'test-dashboard-config-font-lock) +;;; test-dashboard-config-font-lock.el ends here diff --git a/tests/test-dashboard-config-launchers.el b/tests/test-dashboard-config-launchers.el index 0ac37f878..e7e5dcd53 100644 --- a/tests/test-dashboard-config-launchers.el +++ b/tests/test-dashboard-config-launchers.el @@ -25,20 +25,22 @@ (require 'dashboard-config) -(defconst test-dash--keys '("c" "d" "t" "a" "r" "b" "f" "m" "e" "i" "g" "s" "l")) +;; Telegram moved from "g" to "G" so "g" is free for dashboard refresh. +;; Signal ("S") added as the 14th launcher. +(defconst test-dash--keys '("c" "d" "t" "a" "r" "b" "f" "m" "e" "i" "G" "s" "l" "S")) ;; ----------------------------- launcher table -------------------------------- (ert-deftest test-dashboard-launchers-keys-in-order () - "Normal: 13 launchers with the expected keys in display order." - (should (= 13 (length cj/dashboard--launchers))) + "Normal: 14 launchers with the expected keys in display order." + (should (= 14 (length cj/dashboard--launchers))) (should (equal test-dash--keys (mapcar (lambda (l) (nth 0 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-launchers-labels-in-order () "Normal: labels in display order (Telegram and Slack reordered so Slack sits next to Linear on the last navigator row)." (should (equal '("Code" "Files" "Terminal" "Agenda" "Feeds" "Books" - "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear") + "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear" "Signal") (mapcar (lambda (l) (nth 3 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-row-sizes-cover-all-launchers () @@ -48,19 +50,20 @@ next to Linear on the last navigator row)." ;; --------------------------- navigator rows ---------------------------------- -(ert-deftest test-dashboard-navigator-rows-grouped-4-4-3-2 () - "Normal: navigator derives rows per `cj/dashboard--row-sizes' (4 4 3 2), with -Slack and Linear sharing the last row." +(ert-deftest test-dashboard-navigator-rows-grouped-4-4-3-3 () + "Normal: navigator derives rows per `cj/dashboard--row-sizes' (4 4 3 3), with +Slack, Linear, and Signal sharing the last row." (cl-letf (((symbol-function 'nerd-icons-faicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-devicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-mdicon) (lambda (n &rest _) (concat "I:" n))) - ((symbol-function 'nerd-icons-octicon) (lambda (n &rest _) (concat "I:" n)))) + ((symbol-function 'nerd-icons-octicon) (lambda (n &rest _) (concat "I:" n))) + ((symbol-function 'nerd-icons-codicon) (lambda (n &rest _) (concat "I:" n)))) (let ((rows (cj/dashboard--navigator-rows))) (should (= 4 (length rows))) - (should (equal '(4 4 3 2) (mapcar #'length rows))) + (should (equal '(4 4 3 3) (mapcar #'length rows))) (should (equal '("Code" "Files" "Terminal" "Agenda") (mapcar (lambda (b) (nth 1 b)) (nth 0 rows)))) - (should (equal '("Slack" "Linear") + (should (equal '("Slack" "Linear" "Signal") (mapcar (lambda (b) (nth 1 b)) (nth 3 rows)))) (let ((btn (car (car rows)))) ; (icon label tooltip action nil " " "") (should (string= "I:nf-fa-code" (nth 0 btn))) @@ -83,7 +86,7 @@ Slack and Linear sharing the last row." (let ((map (make-sparse-keymap)) (calls nil)) (cl-letf (((symbol-function 'projectile-switch-project) (lambda (&rest _) (push 'code calls))) ((symbol-function 'dirvish) (lambda (&rest _) (push 'files calls))) - ((symbol-function 'ghostel) (lambda (&rest _) (push 'term calls))) + ((symbol-function 'cj/term-toggle) (lambda (&rest _) (push 'term calls))) ((symbol-function 'cj/main-agenda-display) (lambda (&rest _) (push 'agenda calls))) ((symbol-function 'cj/elfeed-open) (lambda (&rest _) (push 'feeds calls))) ((symbol-function 'calibredb) (lambda (&rest _) (push 'books calls))) @@ -94,7 +97,8 @@ Slack and Linear sharing the last row." ((symbol-function 'cj/erc-switch-to-buffer-with-completion) (lambda (&rest _) (push 'irc calls))) ((symbol-function 'cj/slack-start) (lambda (&rest _) (push 'slack calls))) ((symbol-function 'cj/telega) (lambda (&rest _) (push 'tg calls))) - ((symbol-function 'pearl-list-issues) (lambda (&rest _) (push 'linear calls)))) + ((symbol-function 'pearl-list-issues) (lambda (&rest _) (push 'linear calls))) + ((symbol-function 'cj/signel-message) (lambda (&rest _) (push 'signal calls)))) (cj/dashboard--bind-launchers map) (dolist (key test-dash--keys) (call-interactively (keymap-lookup map key))) @@ -103,7 +107,8 @@ Slack and Linear sharing the last row." (should (memq 'linear calls)) (should (memq 'm-toggle calls)) (should (memq 'm-load calls)) - (should (= 14 (length calls)))))) ; 13 keys, Music fires two + (should (memq 'signal calls)) + (should (= 15 (length calls)))))) ; 14 keys, Music fires two (provide 'test-dashboard-config-launchers) ;;; test-dashboard-config-launchers.el ends here diff --git a/tests/test-dashboard-config-recentf-exclude.el b/tests/test-dashboard-config-recentf-exclude.el new file mode 100644 index 000000000..f35b3eda1 --- /dev/null +++ b/tests/test-dashboard-config-recentf-exclude.el @@ -0,0 +1,33 @@ +;;; test-dashboard-config-recentf-exclude.el --- recentf-exclude is not clobbered -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--dashboard-exclude-emms-from-recentf' adds the EMMS history pattern +;; to `recentf-exclude'. It must ADD to the list, not replace it, or it +;; wipes the exclusions system-defaults.el set earlier in init order +;; (emacs_bookmarks, elpa, recentf, ElfeedDB, airootfs). + +;;; Code: + +(require 'ert) +(require 'recentf) ; makes `recentf-exclude' special so the let below is dynamic + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'testutil-general) +(require 'dashboard-config) + +(ert-deftest test-dashboard-config-exclude-emms-preserves-existing-entries () + "Error: excluding the EMMS history preserves prior recentf-exclude entries." + (let ((recentf-exclude (list "emacs_bookmarks" "airootfs"))) + (cj/--dashboard-exclude-emms-from-recentf) + (should (member "/emms/history" recentf-exclude)) + (should (member "emacs_bookmarks" recentf-exclude)) + (should (member "airootfs" recentf-exclude)))) + +(ert-deftest test-dashboard-config-exclude-emms-adds-the-pattern () + "Normal: the EMMS history pattern is present after the call." + (let ((recentf-exclude nil)) + (cj/--dashboard-exclude-emms-from-recentf) + (should (member "/emms/history" recentf-exclude)))) + +(provide 'test-dashboard-config-recentf-exclude) +;;; test-dashboard-config-recentf-exclude.el ends here diff --git a/tests/test-dev-fkeys--f6-current-file-tests-impl.el b/tests/test-dev-fkeys--f6-current-file-tests-impl.el index 1cf222305..2d8e43858 100644 --- a/tests/test-dev-fkeys--f6-current-file-tests-impl.el +++ b/tests/test-dev-fkeys--f6-current-file-tests-impl.el @@ -111,7 +111,7 @@ runner instead of erroring as unsupported." (let ((compile-called nil)) (cl-letf (((symbol-function 'compile) (lambda (cmd) (setq compile-called cmd))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/--f6-current-file-tests-impl "/home/u/proj/src/foo.test.ts" "/home/u/proj/") (should (stringp compile-called)) diff --git a/tests/test-dev-fkeys--f6-current-file-tests.el b/tests/test-dev-fkeys--f6-current-file-tests.el index 3f6adc255..97c1c7675 100644 --- a/tests/test-dev-fkeys--f6-current-file-tests.el +++ b/tests/test-dev-fkeys--f6-current-file-tests.el @@ -16,7 +16,7 @@ (ert-deftest test-dev-fkeys-f6-current-file-tests-routes-to-impl () "Normal: C-F6 invokes the orchestrator with buffer file and projectile root." (let (seen-file seen-root) - (cl-letf (((symbol-function 'buffer-file-name) (lambda () "/p/foo.el")) + (cl-letf (((symbol-function 'buffer-file-name) (lambda (&rest _) "/p/foo.el")) ((symbol-function 'cj/--f4-project-root) (lambda () "/p/")) ((symbol-function 'cj/--f6-current-file-tests-impl) (lambda (file root) diff --git a/tests/test-dev-fkeys--f6-test-runner-cmd-for.el b/tests/test-dev-fkeys--f6-test-runner-cmd-for.el index 9a5526125..d7b6a0597 100644 --- a/tests/test-dev-fkeys--f6-test-runner-cmd-for.el +++ b/tests/test-dev-fkeys--f6-test-runner-cmd-for.el @@ -126,13 +126,13 @@ neither tool is present, the user gets a clear runner-not-found error rather than a silent nil that F6's outer wrapper interprets as \"language unsupported.\"" (cl-letf (((symbol-function 'executable-find) - (lambda (_) nil))) + (lambda (_ &rest _) nil))) (should (equal (cj/--f6-test-runner-cmd-for 'typescript t "src/foo.test.ts" "foo" "src") "npx --no-install jest src/foo.test.ts"))) (cl-letf (((symbol-function 'executable-find) - (lambda (p) (when (equal p "vitest") "/usr/bin/vitest")))) + (lambda (p &rest _) (when (equal p "vitest") "/usr/bin/vitest")))) (should (equal (cj/--f6-test-runner-cmd-for 'typescript t "src/foo.test.ts" "foo" "src") diff --git a/tests/test-dev-fkeys--f6-test-runner.el b/tests/test-dev-fkeys--f6-test-runner.el index eb9cec5ef..d5f58a66d 100644 --- a/tests/test-dev-fkeys--f6-test-runner.el +++ b/tests/test-dev-fkeys--f6-test-runner.el @@ -79,7 +79,7 @@ Components integrated: (lambda (&rest _) "Current file's tests")) ((symbol-function 'projectile-test-project) (lambda (_arg) nil)) ((symbol-function 'cj/--f4-project-root) (lambda () "/p/")) - ((symbol-function 'buffer-file-name) (lambda () "/p/foo.el")) + ((symbol-function 'buffer-file-name) (lambda (&rest _) "/p/foo.el")) ((symbol-function 'cj/--f6-current-file-tests-impl) (lambda (file root) (setq seen-file file seen-root root)))) diff --git a/tests/test-dev-fkeys--projectile-advice-install.el b/tests/test-dev-fkeys--projectile-advice-install.el index bfa9b691f..d0a9a9cc0 100644 --- a/tests/test-dev-fkeys--projectile-advice-install.el +++ b/tests/test-dev-fkeys--projectile-advice-install.el @@ -16,7 +16,7 @@ "When Projectile is not loaded, registration should use `eval-after-load'." (let (registered-feature registered-form install-called) (cl-letf (((symbol-function 'featurep) - (lambda (feature) (and (not (eq feature 'projectile)) + (lambda (feature &rest _) (and (not (eq feature 'projectile)) (featurep feature)))) ((symbol-function 'eval-after-load) (lambda (feature form) @@ -33,7 +33,7 @@ "When Projectile is already loaded, registration should install immediately." (let (install-called eval-after-load-called) (cl-letf (((symbol-function 'featurep) - (lambda (feature) (eq feature 'projectile))) + (lambda (feature &rest _) (eq feature 'projectile))) ((symbol-function 'eval-after-load) (lambda (&rest _args) (setq eval-after-load-called t))) ((symbol-function 'cj/--projectile-install-revert-advice) diff --git a/tests/test-dirvish-config-dired-line-directory.el b/tests/test-dirvish-config-dired-line-directory.el deleted file mode 100644 index 7f344c7c0..000000000 --- a/tests/test-dirvish-config-dired-line-directory.el +++ /dev/null @@ -1,56 +0,0 @@ -;;; test-dirvish-config-dired-line-directory.el --- Tests for the directory-line predicate -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/--dired-line-is-directory-p' is the testable predicate behind -;; `cj/dired-mark-all-visible-files'. Dired buffers prefix each file -;; line with a one-char mark column followed by the `ls -l' output, so -;; column 2 is the file-type letter (`d' for directory, `-' for regular -;; file). The wrapper iterates the buffer and skips lines this -;; predicate returns t for; the iteration stays dired-coupled and -;; untested, but the line-classification logic is now isolated. - -;;; Code: - -(require 'ert) -(require 'package) - -(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) -(package-initialize) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "elpa/dirvish-2.3.0/extensions" - user-emacs-directory)) -(require 'user-constants) -(require 'keybindings) -(require 'dirvish-config) - -(ert-deftest test-cj--dired-line-is-directory-p-unmarked-directory () - "Normal: an unmarked directory line (` drwx...') matches." - (should (cj/--dired-line-is-directory-p - " drwxr-xr-x 1 me me 4096 May 10 13:00 subdir/"))) - -(ert-deftest test-cj--dired-line-is-directory-p-marked-directory () - "Normal: a star-marked directory line (`* drwx...') matches." - (should (cj/--dired-line-is-directory-p - "* drwxr-xr-x 1 me me 4096 May 10 13:00 subdir/"))) - -(ert-deftest test-cj--dired-line-is-directory-p-regular-file () - "Normal: a regular file line (` -rw...') does not match." - (should-not (cj/--dired-line-is-directory-p - " -rw-r--r-- 1 me me 42 May 10 13:00 notes.txt"))) - -(ert-deftest test-cj--dired-line-is-directory-p-symlink-line () - "Boundary: a symlink line (` lrwx...') does not match -- only `d' is a dir." - (should-not (cj/--dired-line-is-directory-p - " lrwxrwxrwx 1 me me 12 May 10 13:00 link -> target"))) - -(ert-deftest test-cj--dired-line-is-directory-p-empty-line () - "Boundary: an empty string does not match." - (should-not (cj/--dired-line-is-directory-p ""))) - -(ert-deftest test-cj--dired-line-is-directory-p-header-line () - "Boundary: a dired header (` /path/to:') or `total' line does not match." - (should-not (cj/--dired-line-is-directory-p " /home/me/projects:")) - (should-not (cj/--dired-line-is-directory-p " total 24"))) - -(provide 'test-dirvish-config-dired-line-directory) -;;; test-dirvish-config-dired-line-directory.el ends here diff --git a/tests/test-dirvish-config-drill.el b/tests/test-dirvish-config-drill.el index f26de6d87..de0541a0c 100644 --- a/tests/test-dirvish-config-drill.el +++ b/tests/test-dirvish-config-drill.el @@ -34,7 +34,7 @@ "Normal: an `.org' file at point is opened and drilled." (let (opened (drilled 0)) (cl-letf (((symbol-function 'dired-get-filename) (lambda (&rest _) "/tmp/decks/cards.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'cj/drill-this-file) (lambda (&rest _) (cl-incf drilled)))) (cj/dirvish-drill-file)) (should (equal "/tmp/decks/cards.org" opened)) @@ -44,7 +44,7 @@ "Boundary: the `.org' check ignores case." (let (opened) (cl-letf (((symbol-function 'dired-get-filename) (lambda (&rest _) "/tmp/decks/CARDS.ORG")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'cj/drill-this-file) #'ignore)) (cj/dirvish-drill-file)) (should (equal "/tmp/decks/CARDS.ORG" opened)))) diff --git a/tests/test-dirvish-config-hard-delete-command.el b/tests/test-dirvish-config-hard-delete-command.el new file mode 100644 index 000000000..eb12d2830 --- /dev/null +++ b/tests/test-dirvish-config-hard-delete-command.el @@ -0,0 +1,47 @@ +;;; test-dirvish-config-hard-delete-command.el --- Tests for cj/--dirvish-hard-delete-command -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--dirvish-hard-delete-command' is the pure string builder behind the +;; forced `sudo rm -rf' hard-delete bound to D in dirvish. It shell-quotes +;; every path and guards the list with `--' so a leading-dash or space-bearing +;; filename can't be misread. The interactive command (prompt + shell-command) +;; is verified live, not here. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'dirvish-config) + +(ert-deftest test-dirvish-config-hard-delete-command-multiple () + "Normal: two paths are quoted and joined behind `sudo rm -rf -- '." + (should (equal (cj/--dirvish-hard-delete-command '("/tmp/a.txt" "/tmp/b.txt")) + "sudo rm -rf -- /tmp/a.txt /tmp/b.txt"))) + +(ert-deftest test-dirvish-config-hard-delete-command-single () + "Boundary: a single path still carries the `--' option terminator." + (should (equal (cj/--dirvish-hard-delete-command '("/tmp/report.pdf")) + "sudo rm -rf -- /tmp/report.pdf"))) + +(ert-deftest test-dirvish-config-hard-delete-command-spaces-and-dash () + "Boundary: a path with spaces is shell-quoted, and `--' protects a +leading-dash filename from being read as an option." + (let ((cmd (cj/--dirvish-hard-delete-command + '("/tmp/my file.txt" "/tmp/-rf")))) + ;; `--' precedes the paths so `-rf' is a target, not an option. + (should (string-prefix-p "sudo rm -rf -- " cmd)) + ;; the space-bearing path is quoted (not a bare " " splitting the args). + (should (string-match-p (regexp-quote (shell-quote-argument "/tmp/my file.txt")) + cmd)) + (should (string-match-p (regexp-quote (shell-quote-argument "/tmp/-rf")) + cmd)))) + +(ert-deftest test-dirvish-config-hard-delete-command-empty () + "Error: an empty list yields just the prefix (no targets) -- the +interactive command never reaches here, guarding `No file at point' first." + (should (equal (cj/--dirvish-hard-delete-command '()) + "sudo rm -rf -- "))) + +(provide 'test-dirvish-config-hard-delete-command) +;;; test-dirvish-config-hard-delete-command.el ends here diff --git a/tests/test-dirvish-config-mark-all-visible.el b/tests/test-dirvish-config-mark-all-visible.el new file mode 100644 index 000000000..5ed01440c --- /dev/null +++ b/tests/test-dirvish-config-mark-all-visible.el @@ -0,0 +1,68 @@ +;;; test-dirvish-config-mark-all-visible.el --- Tests for marking all visible files -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/dired-mark-all-visible-files' marks every regular file in a Dired +;; buffer and leaves directories unmarked. The loop is exercised here against +;; a real Dired buffer over a temp directory (the line predicate has its own +;; unit tests). The regression this pins: `dired-mark' advances point itself, +;; so an extra `forward-line' skipped every other file and only alternate files +;; got marked. + +;;; Code: + +(require 'ert) +(require 'package) +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "elpa/dirvish-2.3.0/extensions" + user-emacs-directory)) +(require 'user-constants) +(require 'keybindings) +(require 'dirvish-config) +(require 'dired) + +(defun test-dirvish--marked-count () + "Return the number of `*'-marked lines in the current Dired buffer." + (let ((n 0)) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (looking-at-p "^\\*") (setq n (1+ n))) + (forward-line 1))) + n)) + +(ert-deftest test-dirvish-mark-all-visible-marks-every-file () + "Normal: all regular files get marked, no skips. +Three files plus a subdirectory; the count of marks must equal the file count." + (let ((dir (make-temp-file "dirvish-mark-test-" t))) + (unwind-protect + (progn + (dolist (f '("a.txt" "b.txt" "c.txt")) + (write-region "" nil (expand-file-name f dir))) + (make-directory (expand-file-name "subdir" dir)) + (let ((buf (dired-noselect dir))) + (unwind-protect + (with-current-buffer buf + (cj/dired-mark-all-visible-files) + (should (= 3 (test-dirvish--marked-count)))) + (kill-buffer buf)))) + (delete-directory dir t)))) + +(ert-deftest test-dirvish-mark-all-visible-leaves-directories-unmarked () + "Boundary: a directory line is never marked." + (let ((dir (make-temp-file "dirvish-mark-test-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "only.txt" dir)) + (make-directory (expand-file-name "adir" dir)) + (let ((buf (dired-noselect dir))) + (unwind-protect + (with-current-buffer buf + (cj/dired-mark-all-visible-files) + (should (= 1 (test-dirvish--marked-count)))) + (kill-buffer buf)))) + (delete-directory dir t)))) + +(provide 'test-dirvish-config-mark-all-visible) +;;; test-dirvish-config-mark-all-visible.el ends here diff --git a/tests/test-dirvish-config-playlist.el b/tests/test-dirvish-config-playlist.el index d059a899a..14bb94ac7 100644 --- a/tests/test-dirvish-config-playlist.el +++ b/tests/test-dirvish-config-playlist.el @@ -10,6 +10,7 @@ ;;; Code: (require 'ert) +(require 'cl-lib) (require 'package) (setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) @@ -93,5 +94,59 @@ lowercase extension list." (dolist (bad '("../evil" "../../etc/cron" "/etc/passwd" "sub/dir/name")) (should-not (cj/--playlist-name-safe-p bad)))) +;;; cj/--playlist-resolve-target +;; +;; Drives the real `file-exists-p' against a temp `music-dir' (mocking a C +;; primitive triggers a native-comp trampoline rebuild that fails under +;; --batch); only the ordinary `read-string' / `read-char-choice' prompts are +;; stubbed. + +(ert-deftest test-cj--playlist-resolve-target-returns-path-for-new-name () + "Normal: a safe name with no existing file returns its .m3u path under music-dir." + (let* ((music-dir (make-temp-file "cj-playlist-" t))) + (unwind-protect + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "roadtrip"))) + (should (equal (expand-file-name "roadtrip.m3u" music-dir) + (cj/--playlist-resolve-target)))) + (delete-directory music-dir t)))) + +(ert-deftest test-cj--playlist-resolve-target-reprompts-on-unsafe-name () + "Boundary: an unsafe name (with `/') re-prompts until a safe name is given." + (let* ((music-dir (make-temp-file "cj-playlist-" t)) + (answers '("../escape" "safe")) + (asked 0)) + (unwind-protect + (cl-letf (((symbol-function 'read-string) + (lambda (&rest _) (prog1 (nth asked answers) (cl-incf asked)))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (should (equal (expand-file-name "safe.m3u" music-dir) + (cj/--playlist-resolve-target))) + (should (= 2 asked))) + (delete-directory music-dir t)))) + +(ert-deftest test-cj--playlist-resolve-target-overwrite-returns-existing-path () + "Normal: when the target exists, choosing overwrite returns the same path." + (let* ((music-dir (make-temp-file "cj-playlist-" t)) + (existing (expand-file-name "mix.m3u" music-dir))) + (unwind-protect + (progn + (with-temp-file existing (insert "old\n")) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "mix")) + ((symbol-function 'read-char-choice) (lambda (&rest _) ?o))) + (should (equal existing (cj/--playlist-resolve-target))))) + (delete-directory music-dir t)))) + +(ert-deftest test-cj--playlist-resolve-target-cancel-signals-user-error () + "Error: when the target exists, choosing cancel aborts with a `user-error'." + (let* ((music-dir (make-temp-file "cj-playlist-" t)) + (existing (expand-file-name "mix.m3u" music-dir))) + (unwind-protect + (progn + (with-temp-file existing (insert "old\n")) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "mix")) + ((symbol-function 'read-char-choice) (lambda (&rest _) ?c))) + (should-error (cj/--playlist-resolve-target) :type 'user-error))) + (delete-directory music-dir t)))) + (provide 'test-dirvish-config-playlist) ;;; test-dirvish-config-playlist.el ends here diff --git a/tests/test-dirvish-config-popup.el b/tests/test-dirvish-config-popup.el new file mode 100644 index 000000000..2bd3a192c --- /dev/null +++ b/tests/test-dirvish-config-popup.el @@ -0,0 +1,248 @@ +;;; test-dirvish-config-popup.el --- Dirvish Hyprland popup tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the Hyprland Super+F dirvish popup. The launcher opens an +;; emacsclient frame named "dirvish" (window rules float/size/center it by that +;; name) and runs `cj/dirvish-popup', which opens Dirvish rooted at home. `q' +;; runs `cj/dirvish-popup-quit': in the popup frame it quits Dirvish and deletes +;; the frame; in any other frame it quits Dirvish normally. Covered here: frame +;; discovery by name, the emacsclient focus race on open, and the quit dispatch +;; on every frame condition. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'dirvish-config) + +;;; cj/--dirvish-popup-frame (find the popup frame by name) + +(ert-deftest test-dirvish-config-popup-frame-found () + "Normal: returns the live frame whose name is \"dirvish\"." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fb fc))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) + (lambda (f _p) (if (eq f 'fb) "dirvish" "other")))) + (should (eq (cj/--dirvish-popup-frame) 'fb)))) + +(ert-deftest test-dirvish-config-popup-frame-none () + "Boundary: no popup frame present yields nil." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fc))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) (lambda (_f _p) "other"))) + (should-not (cj/--dirvish-popup-frame)))) + +(ert-deftest test-dirvish-config-popup-frame-skips-dead () + "Boundary: a dead frame named \"dirvish\" is skipped." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fb))) + ((symbol-function 'frame-live-p) (lambda (f) (not (eq f 'fb)))) + ((symbol-function 'frame-parameter) (lambda (_f _p) "dirvish"))) + (should (eq (cj/--dirvish-popup-frame) 'fa)))) + +;;; cj/dirvish-popup (open dirvish in the named frame) + +(ert-deftest test-dirvish-config-popup-selects-named-frame () + "Integration: cj/dirvish-popup focuses the \"dirvish\" frame found by name, +not whatever frame happens to be selected (the emacsclient -c focus race). + +Components integrated: +- cj/dirvish-popup (real) +- cj/--dirvish-popup-frame (MOCKED — returns a sentinel frame) +- select-frame-set-input-focus (MOCKED — records the focused frame) +- dirvish (MOCKED — records the path opened)" + (let ((focused nil) (opened nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup-frame)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f))) + ((symbol-function 'dirvish) (lambda (&optional p) (setq opened (or p t))))) + (cj/dirvish-popup)) + (should (eq focused 'popup-frame)) + (should opened))) + +(ert-deftest test-dirvish-config-popup-no-frame-still-opens () + "Integration: with no popup frame found, cj/dirvish-popup skips the focus call +and still opens Dirvish (no error)." + (let ((focused 'unset) (opened nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f))) + ((symbol-function 'dirvish) (lambda (&optional _p) (setq opened t)))) + (cj/dirvish-popup)) + (should (eq focused 'unset)) + (should opened))) + +;;; cj/dirvish-popup-quit (quit; delete the popup frame only when in it) + +(ert-deftest test-dirvish-config-popup-quit-in-popup-deletes-frame () + "Normal: in the popup frame, q quits Dirvish and deletes the popup frame." + (let ((quit 0) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'popup)) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'dirvish-quit) (lambda () (cl-incf quit))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (= quit 1)) + (should (eq deleted 'popup)))) + +(ert-deftest test-dirvish-config-popup-quit-normal-frame-keeps-frame () + "Boundary: with no popup frame, q quits Dirvish and deletes nothing." + (let ((quit 0) (deleted 'unset)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'selected-frame) (lambda () 'main)) + ((symbol-function 'dirvish-quit) (lambda () (cl-incf quit))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (= quit 1)) + (should (eq deleted 'unset)))) + +(ert-deftest test-dirvish-config-popup-quit-popup-not-selected-keeps-frame () + "Boundary: the popup exists but a different frame is selected — q quits Dirvish +in that frame and does not delete the popup." + (let ((quit 0) (deleted 'unset)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'main)) + ((symbol-function 'dirvish-quit) (lambda () (cl-incf quit))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (= quit 1)) + (should (eq deleted 'unset)))) + +(ert-deftest test-dirvish-config-popup-quit-survives-dirvish-quit-error () + "Error: a signal from dirvish-quit in the popup still deletes the frame." + (let ((deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'popup)) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'dirvish-quit) (lambda () (error "boom"))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/dirvish-popup-quit)) + (should (eq deleted 'popup)))) + +;;; cj/dirvish-popup-focus-existing (second-launch re-use guard) + +(ert-deftest test-dirvish-config-popup-focus-existing-found () + "Normal: an existing popup is focused and t is returned." + (let ((focused nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f)))) + (should (eq (cj/dirvish-popup-focus-existing) t)) + (should (eq focused 'popup))))) + +(ert-deftest test-dirvish-config-popup-focus-existing-none () + "Boundary: no popup present — returns nil and focuses nothing." + (let ((focused 'unset)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f)))) + (should-not (cj/dirvish-popup-focus-existing)) + (should (eq focused 'unset))))) + +;;; cj/--dirvish-popup-selected-p + +(ert-deftest test-dirvish-config-popup-selected-p-true () + "Normal: true when the selected frame is the popup frame." + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'popup))) + (should (cj/--dirvish-popup-selected-p)))) + +(ert-deftest test-dirvish-config-popup-selected-p-false-other-frame () + "Boundary: false when a different frame is selected." + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'selected-frame) (lambda () 'main))) + (should-not (cj/--dirvish-popup-selected-p)))) + +(ert-deftest test-dirvish-config-popup-selected-p-false-no-popup () + "Boundary: false when no popup frame exists." + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'selected-frame) (lambda () 'main))) + (should-not (cj/--dirvish-popup-selected-p)))) + +;;; cj/dirvish-popup-find-file (popup = launcher; outside = plain find-file) + +(ert-deftest test-dirvish-config-popup-find-file-in-popup-file-launches-external () + "Normal: in the popup, a file at point opens via cj/xdg-open, not in-frame." + (let ((opened nil) (visited nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-selected-p) (lambda () t)) + ((symbol-function 'dired-get-file-for-visit) (lambda () "/tmp/a.mp4")) + ((symbol-function 'file-directory-p) (lambda (_f) nil)) + ((symbol-function 'cj/xdg-open) (lambda (f) (setq opened f))) + ((symbol-function 'dired-find-file) (lambda () (setq visited t)))) + (cj/dirvish-popup-find-file)) + (should (equal opened "/tmp/a.mp4")) + (should-not visited))) + +(ert-deftest test-dirvish-config-popup-find-file-in-popup-dir-navigates () + "Boundary: in the popup, a directory at point is entered normally." + (let ((opened nil) (visited nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-selected-p) (lambda () t)) + ((symbol-function 'dired-get-file-for-visit) (lambda () "/tmp/dir/")) + ((symbol-function 'file-directory-p) (lambda (_f) t)) + ((symbol-function 'cj/xdg-open) (lambda (f) (setq opened f))) + ((symbol-function 'dired-find-file) (lambda () (setq visited t)))) + (cj/dirvish-popup-find-file)) + (should visited) + (should-not opened))) + +(ert-deftest test-dirvish-config-popup-find-file-outside-popup-is-plain-find-file () + "Boundary: outside the popup, behaves exactly like dired-find-file." + (let ((opened nil) (visited nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-selected-p) (lambda () nil)) + ((symbol-function 'cj/xdg-open) (lambda (f) (setq opened f))) + ((symbol-function 'dired-find-file) (lambda () (setq visited t)))) + (cj/dirvish-popup-find-file)) + (should visited) + (should-not opened))) + +;;; cj/--dirvish-popup-focus-watch (dismiss on focus loss, armed after focus) + +(ert-deftest test-dirvish-config-popup-focus-watch-focused-arms-flag () + "Normal: while the popup is focused, the watch sets the had-focus flag and +deletes nothing." + (let ((params '()) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'frame-focus-state) (lambda (_f) t)) + ((symbol-function 'frame-parameter) (lambda (_f p) (plist-get params p))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setq params (plist-put params p v)))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should (plist-get params 'cj-dirvish-popup-had-focus)) + (should-not deleted))) + +(ert-deftest test-dirvish-config-popup-focus-watch-unfocused-after-arming-deletes () + "Normal: lost focus after having held it — the popup is deleted." + (let ((params (list 'cj-dirvish-popup-had-focus t)) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'frame-focus-state) (lambda (_f) nil)) + ((symbol-function 'frame-parameter) (lambda (_f p) (plist-get params p))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setq params (plist-put params p v)))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should (eq deleted 'popup)))) + +(ert-deftest test-dirvish-config-popup-focus-watch-unfocused-before-arming-keeps () + "Boundary: not focused and never armed (the creation race) — NOT deleted." + (let ((params '()) (deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () 'popup)) + ((symbol-function 'frame-focus-state) (lambda (_f) nil)) + ((symbol-function 'frame-parameter) (lambda (_f p) (plist-get params p))) + ((symbol-function 'set-frame-parameter) + (lambda (_f p v) (setq params (plist-put params p v)))) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should-not deleted))) + +(ert-deftest test-dirvish-config-popup-focus-watch-no-popup-is-noop () + "Error: with no popup frame, the watch does nothing and doesn't raise." + (let ((deleted nil)) + (cl-letf (((symbol-function 'cj/--dirvish-popup-frame) (lambda () nil)) + ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) + (cj/--dirvish-popup-focus-watch)) + (should-not deleted))) + +(provide 'test-dirvish-config-popup) +;;; test-dirvish-config-popup.el ends here diff --git a/tests/test-dirvish-config-print.el b/tests/test-dirvish-config-print.el index ab6d073f0..308d00f68 100644 --- a/tests/test-dirvish-config-print.el +++ b/tests/test-dirvish-config-print.el @@ -50,18 +50,18 @@ (ert-deftest test-dirvish-print-program-prefers-lp () "Normal: `lp' is used when available." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lp") "/usr/bin/lp")))) + (lambda (cmd &rest _) (when (equal cmd "lp") "/usr/bin/lp")))) (should (equal (cj/--print-program) "/usr/bin/lp")))) (ert-deftest test-dirvish-print-program-falls-back-to-lpr () "Boundary: `lpr' is used when `lp' is missing." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (when (equal cmd "lpr") "/usr/bin/lpr")))) + (lambda (cmd &rest _) (when (equal cmd "lpr") "/usr/bin/lpr")))) (should (equal (cj/--print-program) "/usr/bin/lpr")))) (ert-deftest test-dirvish-print-program-none-available () "Error: nil when neither `lp' nor `lpr' is on PATH." - (cl-letf (((symbol-function 'executable-find) (lambda (_cmd) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_cmd &rest _) nil))) (should-not (cj/--print-program)))) ;;; ---------------------------- cj/dirvish-print-file ------------------------- diff --git a/tests/test-dirvish-config-public-wrappers.el b/tests/test-dirvish-config-public-wrappers.el index 0a9998646..d1141d33a 100644 --- a/tests/test-dirvish-config-public-wrappers.el +++ b/tests/test-dirvish-config-public-wrappers.el @@ -101,22 +101,9 @@ confused when several built-ins are overridden in the same test." (when (file-exists-p dst) (delete-file dst))))) ;;; cj/dired-mark-all-visible-files - -(ert-deftest test-dirvish-mark-all-visible-skips-directories () - "Normal: directory lines are skipped, file lines are marked." - (let ((marks 0)) - (with-temp-buffer - ;; Real dired listing has lines like " drwxr... dir/" or " -rw... file". - ;; The helper `cj/--dired-line-is-directory-p' matches "<space>d". - (insert " drwxr-xr-x subdir\n" - " -rw-r--r-- file1.txt\n" - " -rw-r--r-- file2.txt\n") - (goto-char (point-min)) - (cl-letf (((symbol-function 'dired-mark) - (lambda (&rest _) (cl-incf marks)))) - (cj/dired-mark-all-visible-files))) - ;; 2 file lines marked; the directory line + the trailing empty line skipped. - (should (= marks 2)))) +;; Covered by test-dirvish-config-mark-all-visible.el, which exercises the loop +;; against a real Dired buffer (the previous fake-buffer mock coupled to the +;; retired regex helper). ;;; cj/dired-copy-path-as-kill @@ -137,7 +124,7 @@ confused when several built-ins are overridden in the same test." ((symbol-function 'cj/get-project-root) (lambda () nil)) ((symbol-function 'kill-new) - (lambda (s) (setq killed s))) + (lambda (s &rest _) (setq killed s))) ((symbol-function 'message) #'ignore)) (cj/dired-copy-path-as-kill)) (should (stringp killed)) @@ -152,7 +139,7 @@ confused when several built-ins are overridden in the same test." (lambda (&rest _) "/tmp/foo.txt")) ((symbol-function 'cj/get-project-root) (lambda () nil)) ((symbol-function 'kill-new) - (lambda (s) (setq killed s))) + (lambda (s &rest _) (setq killed s))) ((symbol-function 'message) #'ignore)) (cj/dired-copy-path-as-kill t)) (should (string-prefix-p "[[file:" killed)) diff --git a/tests/test-dirvish-config-wallpaper-program.el b/tests/test-dirvish-config-wallpaper-program.el index 556c13100..41d2ad8b2 100644 --- a/tests/test-dirvish-config-wallpaper-program.el +++ b/tests/test-dirvish-config-wallpaper-program.el @@ -28,9 +28,9 @@ '("feh" "--bg-fill")))) (ert-deftest test-cj--wallpaper-program-for-wayland () - "Normal: wayland dispatches to swww with the img subcommand." + "Normal: wayland dispatches to the set-wallpaper script (awww backend + waypaper persist)." (should (equal (cj/--wallpaper-program-for 'wayland) - '("swww" "img")))) + '("set-wallpaper")))) (ert-deftest test-cj--wallpaper-program-for-unknown-returns-nil () "Boundary: an unknown environment returns nil so the wrapper can fall back." diff --git a/tests/test-dirvish-config-wrappers.el b/tests/test-dirvish-config-wrappers.el index bead45830..39f272474 100644 --- a/tests/test-dirvish-config-wrappers.el +++ b/tests/test-dirvish-config-wrappers.el @@ -40,7 +40,7 @@ puts the older one first)." ((symbol-function 'ediff-files) (lambda (a b) (setq ediff-args (list a b)))) ((symbol-function 'current-window-configuration) - (lambda () nil)) + (lambda (&rest _) nil)) ((symbol-function 'add-hook) #'ignore)) (cj/dired-ediff-files) ;; Pair returns (older . newer) so ediff-files sees (older newer). diff --git a/tests/test-dupre-theme.el b/tests/test-dupre-theme.el deleted file mode 100644 index 4d0e786cb..000000000 --- a/tests/test-dupre-theme.el +++ /dev/null @@ -1,261 +0,0 @@ -;;; test-dupre-theme.el --- Tests for dupre-theme -*- lexical-binding: t -*- - -;;; Commentary: - -;; ERT tests for the dupre-theme. - -;;; Code: - -(require 'ert) - -;; Add themes directory to load-path and custom-theme-load-path -(let ((themes-dir (expand-file-name "../themes" (file-name-directory (or load-file-name buffer-file-name))))) - (add-to-list 'load-path themes-dir) - (add-to-list 'custom-theme-load-path themes-dir)) - -(require 'dupre-palette) - -;;; Palette tests - -(ert-deftest dupre-palette-exists () - "Palette constant should be defined." - (should (boundp 'dupre-palette)) - (should (listp dupre-palette))) - -(ert-deftest dupre-palette-has-base-colors () - "Palette should contain essential base colors." - (should (assq 'bg dupre-palette)) - (should (assq 'fg dupre-palette)) - (should (assq 'bg+1 dupre-palette)) - (should (assq 'bg+2 dupre-palette))) - -(ert-deftest dupre-palette-has-accent-colors () - "Palette should contain accent colors." - (should (assq 'yellow dupre-palette)) - (should (assq 'blue dupre-palette)) - (should (assq 'green dupre-palette)) - (should (assq 'red dupre-palette))) - -(ert-deftest dupre-palette-colors-are-hex () - "All palette colors should be valid hex strings." - (dolist (entry dupre-palette) - (let ((color (cadr entry))) - (should (stringp color)) - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" color))))) - -(ert-deftest dupre-get-color-base () - "dupre-get-color should retrieve base colors." - (should (string= (dupre-get-color 'bg) "#151311")) - (should (string= (dupre-get-color 'fg) "#f0fef0")) - (should (string= (dupre-get-color 'yellow) "#d7af5f"))) - -(ert-deftest dupre-get-color-semantic () - "dupre-get-color should resolve semantic mappings." - (should (string= (dupre-get-color 'accent) (dupre-get-color 'yellow))) - (should (string= (dupre-get-color 'err) (dupre-get-color 'intense-red))) - (should (string= (dupre-get-color 'success) (dupre-get-color 'green)))) - -(ert-deftest dupre-get-color-unknown-errors () - "dupre-get-color should error on unknown colors." - (should-error (dupre-get-color 'nonexistent-color))) - -(ert-deftest dupre-with-colors-binds-values () - "dupre-with-colors should bind palette colors as variables." - (dupre-with-colors - (should (string= bg "#151311")) - (should (string= fg "#f0fef0")) - (should (string= yellow "#d7af5f")) - (should (string= blue "#67809c")))) - -(ert-deftest dupre-with-colors-binds-semantic () - "dupre-with-colors should bind semantic colors resolved to values." - (dupre-with-colors - (should (string= accent "#d7af5f")) - (should (string= err "#ff2a00")) - (should (string= success "#a4ac64")))) - -;;; Theme loading tests - -(ert-deftest dupre-theme-loads () - "Theme should load without errors." - (load-theme 'dupre t) - (should (memq 'dupre custom-enabled-themes))) - -(ert-deftest dupre-theme-default-face () - "dupre-theme should set the default face correctly." - (load-theme 'dupre t) - (let ((bg (face-attribute 'default :background)) - (fg (face-attribute 'default :foreground))) - (should (string= bg "#151311")) - (should (string= fg "#f0fef0")))) - -(ert-deftest dupre-theme-comment-face-italic () - "Comments should be rendered in italic slant." - (load-theme 'dupre t) - (should (eq (face-attribute 'font-lock-comment-face :slant) 'italic))) - -(ert-deftest dupre-theme-keyword-face () - "Keywords should use blue color." - (load-theme 'dupre t) - (should (string= (face-attribute 'font-lock-keyword-face :foreground) "#67809c"))) - -(ert-deftest dupre-theme-string-face () - "Strings should use green color." - (load-theme 'dupre t) - (should (string= (face-attribute 'font-lock-string-face :foreground) "#a4ac64"))) - -(ert-deftest dupre-theme-function-face () - "Functions should use terracotta color." - (load-theme 'dupre t) - (should (string= (face-attribute 'font-lock-function-name-face :foreground) "#a7502d"))) - -;;; Org-mode face tests (require org to be loaded) -;; Note: org-level-N faces use :inherit dupre-heading-N -;; We verify inheritance is set up correctly by checking the inherit attribute - -(ert-deftest dupre-theme-org-level-1 () - "Org level 1 should inherit from dupre-heading-1." - (require 'org) - (load-theme 'dupre t) - ;; Verify the inheritance relationship is set - (should (eq (face-attribute 'org-level-1 :inherit) 'dupre-heading-1))) - -(ert-deftest dupre-theme-org-level-2 () - "Org level 2 should inherit from dupre-heading-2." - (require 'org) - (load-theme 'dupre t) - ;; Verify the inheritance relationship is set - (should (eq (face-attribute 'org-level-2 :inherit) 'dupre-heading-2))) - -(ert-deftest dupre-theme-org-todo () - "Org TODO should use intense-red." - (require 'org) - (load-theme 'dupre t) - (should (string= (face-attribute 'org-todo :foreground) "#ff2a00"))) - -(ert-deftest dupre-theme-org-done () - "Org DONE should use green." - (require 'org) - (load-theme 'dupre t) - (should (string= (face-attribute 'org-done :foreground) "#a4ac64"))) - -;;; Diff face tests (require diff-mode to be loaded) - -(ert-deftest dupre-theme-diff-added () - "Diff added should use green foreground." - (require 'diff-mode) - (load-theme 'dupre t) - (should (string= (face-attribute 'diff-added :foreground) "#a4ac64"))) - -(ert-deftest dupre-theme-diff-removed () - "Diff removed should use red foreground." - (require 'diff-mode) - (load-theme 'dupre t) - (should (string= (face-attribute 'diff-removed :foreground) "#d47c59"))) - -;;; UI face tests - -(ert-deftest dupre-theme-mode-line () - "Mode line should have correct background." - (load-theme 'dupre t) - (should (string= (face-attribute 'mode-line :background) "#474544"))) - -(ert-deftest dupre-theme-region () - "Region should use bg+2 as background." - (load-theme 'dupre t) - (should (string= (face-attribute 'region :background) "#474544"))) - -;;; Vertico face tests (skip if vertico not available) - -(ert-deftest dupre-theme-vertico-current () - "Vertico current should use bg+2 background." - (skip-unless (require 'vertico nil t)) - (load-theme 'dupre t) - (should (string= (face-attribute 'vertico-current :background) "#474544"))) - -;;; Rainbow-delimiters tests (skip if package not available) - -(ert-deftest dupre-theme-rainbow-depth-1 () - "Rainbow depth 1 should use blue." - (skip-unless (require 'rainbow-delimiters nil t)) - (load-theme 'dupre t) - (should (string= (face-attribute 'rainbow-delimiters-depth-1-face :foreground) "#67809c"))) - -(ert-deftest dupre-theme-rainbow-depth-2 () - "Rainbow depth 2 should use gray+2." - (skip-unless (require 'rainbow-delimiters nil t)) - (load-theme 'dupre t) - (should (string= (face-attribute 'rainbow-delimiters-depth-2-face :foreground) "#d0cbc0"))) - -;;; Error/warning face tests - -(ert-deftest dupre-theme-error-face () - "Error face should use intense-red." - (load-theme 'dupre t) - (should (string= (face-attribute 'error :foreground) "#ff2a00"))) - -(ert-deftest dupre-theme-warning-face () - "Warning face should use yellow+1." - (load-theme 'dupre t) - (should (string= (face-attribute 'warning :foreground) "#ffd75f"))) - -(ert-deftest dupre-theme-success-face () - "Success face should use green." - (load-theme 'dupre t) - (should (string= (face-attribute 'success :foreground) "#a4ac64"))) - -;;; Face registration - -(ert-deftest dupre-semantic-faces-are-registered () - "Dupre's own faces must be real faces, not just theme specs. -An unregistered face renders only through `:inherit'; applied directly as -a text property (e.g. via `org-todo-keyword-faces') it silently fails. -The defface registration in dupre-faces.el is what makes direct use work." - (load-theme 'dupre t) - (dolist (face '(dupre-accent dupre-heading-1 - dupre-org-todo dupre-org-todo-dim - dupre-org-failed dupre-org-priority-a - dupre-org-priority-a-dim)) - (should (facep face))) - ;; and the theme colours them from the palette - (should (string= (face-attribute 'dupre-org-todo :foreground nil 'default) - "#a4ac64")) - (should (string= (face-attribute 'dupre-org-todo-dim :foreground nil 'default) - "#869038"))) - -;;; Diff face legibility (WCAG contrast) - -(defun dupre-test--channel-luminance (c) - "Linearize an 8-bit channel value C (0-255) per the WCAG formula." - (let ((x (/ c 255.0))) - (if (<= x 0.03928) (/ x 12.92) (expt (/ (+ x 0.055) 1.055) 2.4)))) - -(defun dupre-test--relative-luminance (hex) - "WCAG relative luminance of HEX color \"#rrggbb\"." - (+ (* 0.2126 (dupre-test--channel-luminance (string-to-number (substring hex 1 3) 16))) - (* 0.7152 (dupre-test--channel-luminance (string-to-number (substring hex 3 5) 16))) - (* 0.0722 (dupre-test--channel-luminance (string-to-number (substring hex 5 7) 16))))) - -(defun dupre-test--contrast (fg bg) - "WCAG contrast ratio between hex colors FG and BG." - (let ((l1 (dupre-test--relative-luminance fg)) - (l2 (dupre-test--relative-luminance bg))) - (/ (+ (max l1 l2) 0.05) (+ (min l1 l2) 0.05)))) - -(ert-deftest dupre-diff-changed-faces-meet-wcag-aa () - "Error/Regression: diff-changed and diff-refine-changed must stay legible as -standalone backgrounds (WCAG AA, >= 4.5:1 for normal text). Guards the bug -where diff-refine-changed rendered the default fg (#f0fef0) on the bright-gold -yellow-1 (#ffd700) at 1.35:1 -- unreadable wherever the face is used as a plain -background, not just inside diff-mode's own foreground overlay." - (require 'diff-mode) - (load-theme 'dupre t) - (dolist (face '(diff-changed diff-refine-changed)) - (let ((fg (face-attribute face :foreground nil t)) - (bg (face-attribute face :background nil t))) - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" fg)) - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" bg)) - (should (>= (dupre-test--contrast fg bg) 4.5))))) - -(provide 'test-dupre-theme) -;;; test-dupre-theme.el ends here diff --git a/tests/test-dwim-shell-config-command-fixes.el b/tests/test-dwim-shell-config-command-fixes.el new file mode 100644 index 000000000..2cc3ae72b --- /dev/null +++ b/tests/test-dwim-shell-config-command-fixes.el @@ -0,0 +1,88 @@ +;;; test-dwim-shell-config-command-fixes.el --- zip/backup command builders -*- lexical-binding: t; -*- + +;;; Commentary: +;; Two audit fixes, extracted into top-level command-string builders so they're +;; testable without loading the dwim-shell-command package (the command defuns +;; that call them live inside its use-package :config, which the batch test +;; harness doesn't instantiate): +;; - cj/dwim-shell--zip-single-file-command names the archive <fne>.zip +;; - cj/dwim-shell--dated-backup-command carries a real timestamp, not "$(date)" +;; The third fix (dired menu key M-S-d -> M-D) is a keybinding inside the same +;; :config block; it's verified in the live daemon, not here. + +;;; Code: + +(require 'ert) +(require 'dwim-shell-config) + +(ert-deftest test-dwim-zip-single-file-command-names-archive-dot-zip () + "Normal: the single-file zip template names the archive <fne>.zip, with no +leftover <<e>> that would rebuild the input filename." + (let ((cmd (cj/dwim-shell--zip-single-file-command))) + (should (string-match-p "'<<fne>>\\.zip'" cmd)) + (should-not (string-match-p "<<e>>" cmd)))) + +(ert-deftest test-dwim-dated-backup-command-carries-real-timestamp () + "Normal: the dated-backup template interpolates a real YYYYMMDD_HHMMSS stamp, +so the substitution can't sit dead inside single quotes." + (let ((cmd (cj/dwim-shell--dated-backup-command))) + (should (string-match-p "\\.[0-9]\\{8\\}_[0-9]\\{6\\}\\.bak'" cmd)) + (should-not (string-match-p "\\$(date" cmd)))) + +;;; ----------------------- tar-gzip command builder -------------------------- + +(ert-deftest test-dwim-tar-gzip-command-single-names-after-file () + "Normal: a single marked file names the archive <fne>.tar.gz over <<f>>." + (let ((cmd (cj/dwim-shell--tar-gzip-command t))) + (should (string-match-p "'<<fne>>\\.tar\\.gz'" cmd)) + (should (string-match-p "'<<f>>'" cmd)))) + +(ert-deftest test-dwim-tar-gzip-command-multi-uses-shared-archive () + "Boundary: multiple files tar into a shared archive.tar.gz over <<*>>." + (let ((cmd (cj/dwim-shell--tar-gzip-command nil))) + (should (string-match-p "archive\\.tar\\.gz" cmd)) + (should (string-match-p "'<<\\*>>'" cmd)))) + +;;; --------------------- text-to-speech command builder ---------------------- + +(ert-deftest test-dwim-text-to-speech-command-darwin-uses-say-voice () + "Normal: on darwin the command uses `say' with the chosen voice." + (let ((cmd (cj/dwim-shell--text-to-speech-command 'darwin "Samantha"))) + (should (string-match-p "\\`say -v Samantha " cmd)) + (should (string-match-p "'<<fne>>\\.aiff'" cmd)))) + +(ert-deftest test-dwim-text-to-speech-command-linux-uses-espeak () + "Boundary: a non-darwin system uses `espeak' and ignores the voice." + (let ((cmd (cj/dwim-shell--text-to-speech-command 'gnu/linux "ignored"))) + (should (string-match-p "\\`espeak " cmd)) + (should (string-match-p "'<<fne>>\\.wav'" cmd)) + (should-not (string-match-p "ignored" cmd)))) + +;;; ----------------------- video-trim command builder ------------------------ + +(ert-deftest test-dwim-video-trim-command-beginning-uses-ss () + "Normal: trimming the beginning emits a leading -ss with the start seconds." + (let ((cmd (cj/dwim-shell--video-trim-command "Beginning" 7 0))) + (should (string-match-p "-ss 7 " cmd)) + (should-not (string-match-p "-sseof" cmd)))) + +(ert-deftest test-dwim-video-trim-command-end-uses-sseof () + "Normal: trimming the end emits -sseof with the end seconds, no -ss." + (let ((cmd (cj/dwim-shell--video-trim-command "End" 0 9))) + (should (string-match-p "-sseof -9 " cmd)) + (should-not (string-match-p "-ss [0-9]" cmd)))) + +(ert-deftest test-dwim-video-trim-command-both-uses-ss-and-sseof () + "Normal: trimming both ends emits both -ss start and -sseof end." + (let ((cmd (cj/dwim-shell--video-trim-command "Both" 3 4))) + (should (string-match-p "-ss 3 " cmd)) + (should (string-match-p "-sseof -4 " cmd)))) + +(ert-deftest test-dwim-video-trim-command-negative-seconds-errors () + "Error: a negative second count for the used side signals a user-error." + (should-error (cj/dwim-shell--video-trim-command "Beginning" -1 0) :type 'user-error) + (should-error (cj/dwim-shell--video-trim-command "End" 0 -1) :type 'user-error) + (should-error (cj/dwim-shell--video-trim-command "Both" 0 -2) :type 'user-error)) + +(provide 'test-dwim-shell-config-command-fixes) +;;; test-dwim-shell-config-command-fixes.el ends here diff --git a/tests/test-elfeed-config--decode-html-entities.el b/tests/test-elfeed-config--decode-html-entities.el new file mode 100644 index 000000000..a3fba3c49 --- /dev/null +++ b/tests/test-elfeed-config--decode-html-entities.el @@ -0,0 +1,31 @@ +;;; test-elfeed-config--decode-html-entities.el --- Tests for cj/--decode-html-entities -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--decode-html-entities replaces the six inline replace-regexp-in-string +;; calls that cj/youtube-to-elfeed-feed-format used to hand-decode an og:title. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'elfeed-config) + +(ert-deftest test-elfeed-decode-html-entities-all () + "Normal: every supported entity is decoded." + (should (equal (cj/--decode-html-entities + "a & b <c> "d" 'e'") + "a & b <c> \"d\" 'e'"))) + +(ert-deftest test-elfeed-decode-html-entities-no-entities () + "Boundary: text without entities is unchanged." + (should (equal (cj/--decode-html-entities "plain title") "plain title")) + (should (equal (cj/--decode-html-entities "") ""))) + +(ert-deftest test-elfeed-decode-html-entities-amp-first () + "Boundary: & is decoded before the others (no double-decoding chains)." + (should (equal (cj/--decode-html-entities "Tom & Jerry <3") + "Tom & Jerry <3"))) + +(provide 'test-elfeed-config--decode-html-entities) +;;; test-elfeed-config--decode-html-entities.el ends here diff --git a/tests/test-elfeed-config-helpers.el b/tests/test-elfeed-config-helpers.el index 59a0ed331..16cbb7443 100644 --- a/tests/test-elfeed-config-helpers.el +++ b/tests/test-elfeed-config-helpers.el @@ -39,7 +39,7 @@ (ert-deftest test-elfeed-extract-stream-url-normal-returns-url () "Normal: a successful yt-dlp run returns the trimmed https stream URL." (cl-letf (((symbol-function 'executable-find) - (lambda (p) (and (equal p "yt-dlp") "/usr/bin/yt-dlp"))) + (lambda (p &rest _) (and (equal p "yt-dlp") "/usr/bin/yt-dlp"))) ((symbol-function 'cj/log-silently) #'ignore) ((symbol-function 'call-process) (lambda (_prog _infile _dest _disp &rest _args) @@ -49,7 +49,7 @@ (ert-deftest test-elfeed-extract-stream-url-boundary-non-url-output-is-nil () "Boundary: output that is not an http(s) URL yields nil, not the raw text." - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/yt-dlp")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/yt-dlp")) ((symbol-function 'cj/log-silently) #'ignore) ((symbol-function 'call-process) (lambda (_p _i _d _disp &rest _) (insert "ERROR: unavailable\n") 0))) @@ -57,7 +57,7 @@ (ert-deftest test-elfeed-extract-stream-url-boundary-nonzero-exit-is-nil () "Boundary: a nonzero yt-dlp exit code yields nil." - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/yt-dlp")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/yt-dlp")) ((symbol-function 'cj/log-silently) #'ignore) ((symbol-function 'call-process) (lambda (_p _i _d _disp &rest _) (insert "boom") 1))) @@ -65,7 +65,7 @@ (ert-deftest test-elfeed-extract-stream-url-error-without-yt-dlp () "Error: a missing yt-dlp signals before attempting the call." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/extract-stream-url "u" "best") :type 'error))) ;;; cj/elfeed-process-entries diff --git a/tests/test-elfeed-config-youtube-feed-format.el b/tests/test-elfeed-config-youtube-feed-format.el index bda90aa7d..f6c82881e 100644 --- a/tests/test-elfeed-config-youtube-feed-format.el +++ b/tests/test-elfeed-config-youtube-feed-format.el @@ -65,5 +65,49 @@ (should-error (cj/youtube-to-elfeed-feed-format "https://youtube.com/@t" 'channel)) (should-not (buffer-live-p url-buf))))) +;;; Playlist branch + +(ert-deftest test-elfeed-youtube-playlist-parses-id-and-title () + "Normal: a playlist URL yields the playlist feed line and the og:title." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) + (test-elfeed--url-buffer + "<meta property=\"og:title\" content=\"My Playlist\">")))) + (let ((result (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/playlist?list=PLabc123" 'playlist))) + (should (string-match-p "playlist_id=PLabc123" result)) + (should (string-match-p "My Playlist" result))))) + +(ert-deftest test-elfeed-youtube-playlist-id-stops-at-ampersand () + "Boundary: extra query params after list= are not captured into the id." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) + (test-elfeed--url-buffer + "<meta property=\"og:title\" content=\"X\">")))) + (let ((result (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/playlist?list=PLxyz&index=2" 'playlist))) + (should (string-match-p "playlist_id=PLxyz" result)) + (should-not (string-match-p "index=2" result))))) + +(ert-deftest test-elfeed-youtube-playlist-no-list-param-errors () + "Error: a playlist URL with no list= parameter signals an extraction error." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) (test-elfeed--url-buffer "")))) + (should-error (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/watch?v=abc" 'playlist)))) + +(ert-deftest test-elfeed-youtube-playlist-decodes-html-entities-in-title () + "Normal: HTML entities in the og:title are decoded in the feed comment." + (cl-letf (((symbol-function 'url-retrieve-synchronously) + (lambda (&rest _) + (test-elfeed--url-buffer + (concat "<meta property=\"og:title\" content=\"" + "Rock & Roll 'n' <Test> "X"" + "\">"))))) + (let ((result (cj/youtube-to-elfeed-feed-format + "https://www.youtube.com/playlist?list=PLe" 'playlist))) + (should (string-match-p (regexp-quote "Rock & Roll 'n' <Test> \"X\"") + result))))) + (provide 'test-elfeed-config-youtube-feed-format) ;;; test-elfeed-config-youtube-feed-format.el ends here diff --git a/tests/test-erc-config--generate-buffer-name.el b/tests/test-erc-config--generate-buffer-name.el new file mode 100644 index 000000000..cbc716c82 --- /dev/null +++ b/tests/test-erc-config--generate-buffer-name.el @@ -0,0 +1,31 @@ +;;; test-erc-config--generate-buffer-name.el --- Tests for cj/erc-generate-buffer-name -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/erc-generate-buffer-name formats an ERC buffer name as SERVER-CHANNEL. +;; It was defined inside the erc use-package :config (so unreachable under +;; `make test'); lifting it to top level makes it unit-testable. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'erc-config) + +(ert-deftest test-erc-generate-buffer-name-server-and-channel () + "Normal: a target yields SERVER-CHANNEL." + (should (equal (cj/erc-generate-buffer-name '(:server "libera" :target "#emacs")) + "libera-#emacs"))) + +(ert-deftest test-erc-generate-buffer-name-server-only () + "Boundary: no target yields just the server name." + (should (equal (cj/erc-generate-buffer-name '(:server "libera")) + "libera"))) + +(ert-deftest test-erc-generate-buffer-name-missing-pieces () + "Boundary: missing server/target degrade to empty strings, not nil." + (should (equal (cj/erc-generate-buffer-name '(:target "#emacs")) "-#emacs")) + (should (equal (cj/erc-generate-buffer-name '()) ""))) + +(provide 'test-erc-config--generate-buffer-name) +;;; test-erc-config--generate-buffer-name.el ends here diff --git a/tests/test-erc-config-connected-servers.el b/tests/test-erc-config-connected-servers.el new file mode 100644 index 000000000..394367c3e --- /dev/null +++ b/tests/test-erc-config-connected-servers.el @@ -0,0 +1,49 @@ +;;; test-erc-config-connected-servers.el --- cj/erc-connected-servers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/erc-connected-servers must return only ERC *server* buffers with a live +;; process. The original test compared a buffer's own erc-server-process to the +;; same buffer-local value inside `with-current-buffer', which is always true, so +;; it returned every ERC buffer (channels, queries, dead connections). These +;; tests stub `erc-buffer-list' and the two ERC predicates +;; (`erc-server-or-unjoined-channel-buffer-p' and `erc-server-process-alive') +;; so the classification is exercised without a real IRC connection. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'erc-config) + +(ert-deftest test-erc-connected-servers-keeps-only-live-server-buffers () + "Normal: only buffers that are ERC server buffers with a live process are +returned; a channel buffer and a dead-connection server buffer are excluded." + (let ((b-server (generate-new-buffer " *erc-server*")) + (b-channel (generate-new-buffer " *erc-#chan*")) + (b-dead (generate-new-buffer " *erc-dead*"))) + (unwind-protect + (cl-letf (((symbol-function 'erc-buffer-list) + (lambda (&rest _) (list b-server b-channel b-dead))) + ((symbol-function 'erc-server-or-unjoined-channel-buffer-p) + (lambda (&rest _) (memq (current-buffer) (list b-server b-dead)))) + ((symbol-function 'erc-server-process-alive) + (lambda (&rest _) (eq (current-buffer) b-server)))) + (should (equal (cj/erc-connected-servers) + (list (buffer-name b-server))))) + (mapc #'kill-buffer (list b-server b-channel b-dead))))) + +(ert-deftest test-erc-connected-servers-empty-when-none-alive () + "Boundary: no live server buffers yields an empty list." + (let ((b-channel (generate-new-buffer " *erc-#chan*"))) + (unwind-protect + (cl-letf (((symbol-function 'erc-buffer-list) + (lambda (&rest _) (list b-channel))) + ((symbol-function 'erc-server-or-unjoined-channel-buffer-p) (lambda (&rest _) nil)) + ((symbol-function 'erc-server-process-alive) (lambda (&rest _) nil))) + (should (null (cj/erc-connected-servers)))) + (kill-buffer b-channel)))) + +(provide 'test-erc-config-connected-servers) +;;; test-erc-config-connected-servers.el ends here diff --git a/tests/test-eshell-config--prompt.el b/tests/test-eshell-config--prompt.el new file mode 100644 index 000000000..7073c7e0b --- /dev/null +++ b/tests/test-eshell-config--prompt.el @@ -0,0 +1,75 @@ +;;; test-eshell-config--prompt.el --- Tests for eshell prompt helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the pure prompt-segment helpers added for zsh parity: the +;; .git/HEAD branch reader and the exit-status segment. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'eshell-config) + +(defvar eshell-last-command-status) ; declared special for the status tests + +;;; cj/--eshell-git-branch + +(ert-deftest test-eshell-git-branch-reads-head () + "Normal: a .git/HEAD pointing at a branch returns the branch name." + (let ((dir (make-temp-file "esh-git-" t))) + (unwind-protect + (progn + (make-directory (expand-file-name ".git" dir)) + (with-temp-file (expand-file-name ".git/HEAD" dir) + (insert "ref: refs/heads/feature-x\n")) + (let ((default-directory (file-name-as-directory dir))) + (should (equal (cj/--eshell-git-branch) "feature-x")))) + (delete-directory dir t)))) + +(ert-deftest test-eshell-git-branch-no-repo-nil () + "Boundary: a directory with no .git returns nil." + (let ((dir (make-temp-file "esh-nogit-" t))) + (unwind-protect + (let ((default-directory (file-name-as-directory dir))) + (should-not (cj/--eshell-git-branch))) + (delete-directory dir t)))) + +(ert-deftest test-eshell-git-branch-detached-nil () + "Boundary: a detached HEAD (a raw SHA, no ref) returns nil." + (let ((dir (make-temp-file "esh-detached-" t))) + (unwind-protect + (progn + (make-directory (expand-file-name ".git" dir)) + (with-temp-file (expand-file-name ".git/HEAD" dir) + (insert "a1b2c3d4e5f6\n")) + (let ((default-directory (file-name-as-directory dir))) + (should-not (cj/--eshell-git-branch)))) + (delete-directory dir t)))) + +(ert-deftest test-eshell-git-branch-remote-skipped () + "Boundary: a remote default-directory is skipped (no TRAMP read)." + (let ((default-directory "/ssh:host:/some/path/")) + (should-not (cj/--eshell-git-branch)))) + +;;; cj/--eshell-prompt-status-segment + +(ert-deftest test-eshell-prompt-status-zero-empty () + "Normal: a zero exit status yields an empty segment." + (let ((eshell-last-command-status 0)) + (should (equal (cj/--eshell-prompt-status-segment) "")))) + +(ert-deftest test-eshell-prompt-status-nonzero-bracketed () + "Normal: a non-zero exit status is shown in brackets." + (let ((eshell-last-command-status 1)) + (should (equal (cj/--eshell-prompt-status-segment) " [1]"))) + (let ((eshell-last-command-status 130)) + (should (equal (cj/--eshell-prompt-status-segment) " [130]")))) + +(ert-deftest test-eshell-prompt-status-unset-empty () + "Boundary: an unset status yields an empty segment, no error." + (let ((eshell-last-command-status nil)) + (should (equal (cj/--eshell-prompt-status-segment) "")))) + +(provide 'test-eshell-config--prompt) +;;; test-eshell-config--prompt.el ends here diff --git a/tests/test-external-open-commands.el b/tests/test-external-open-commands.el index c0c83a340..3d8adc15e 100644 --- a/tests/test-external-open-commands.el +++ b/tests/test-external-open-commands.el @@ -81,8 +81,9 @@ ;;; cj/find-file-auto (ert-deftest test-external-open-find-file-auto-routes-media-externally () - "Normal: a `.mp4' filename (in `default-open-extensions') triggers -`cj/xdg-open' instead of the original `find-file'." + "Normal: a non-video external extension (`.docx', in +`default-open-extensions') triggers `cj/xdg-open' instead of the original +`find-file'." (let ((opened nil) (orig-called nil)) (cl-letf (((symbol-function 'cj/xdg-open) @@ -90,8 +91,23 @@ ;; orig-fun replacement -- shouldn't run for a routed extension. ((symbol-function 'cj/find-file-auto--orig-stub) (lambda (&rest _) (setq orig-called t)))) - (cj/find-file-auto #'cj/find-file-auto--orig-stub "/tmp/video.mp4")) - (should (equal opened "/tmp/video.mp4")) + (cj/find-file-auto #'cj/find-file-auto--orig-stub "/tmp/report.docx")) + (should (equal opened "/tmp/report.docx")) + (should-not orig-called))) + +(ert-deftest test-external-open-find-file-auto-routes-video-to-looping-player () + "Normal: a video filename triggers `cj/open-video-looping', not `cj/xdg-open' +or the original `find-file'." + (let ((looped nil) (xdg nil) (orig-called nil)) + (cl-letf (((symbol-function 'cj/open-video-looping) + (lambda (file) (setq looped file))) + ((symbol-function 'cj/xdg-open) + (lambda (_) (setq xdg t))) + ((symbol-function 'cj/find-file-auto--orig-stub) + (lambda (&rest _) (setq orig-called t)))) + (cj/find-file-auto #'cj/find-file-auto--orig-stub "/tmp/clip.mp4")) + (should (equal looped "/tmp/clip.mp4")) + (should-not xdg) (should-not orig-called))) (ert-deftest test-external-open-find-file-auto-passes-through-text-files () @@ -116,5 +132,66 @@ (cj/find-file-auto #'cj/find-file-auto--orig-stub nil)) (should orig-called))) +;;; cj/--video-file-p + +(ert-deftest test-external-open-video-file-p-matches-video () + "Normal: common video extensions match, case-insensitively." + (should (cj/--video-file-p "/tmp/a.mp4")) + (should (cj/--video-file-p "/tmp/a.mkv")) + (should (cj/--video-file-p "/tmp/a.webm")) + (should (cj/--video-file-p "/tmp/A.MP4"))) + +(ert-deftest test-external-open-video-file-p-rejects-non-video () + "Boundary: audio, docs, and nil do not match." + (should-not (cj/--video-file-p "/tmp/a.mp3")) + (should-not (cj/--video-file-p "/tmp/a.txt")) + (should-not (cj/--video-file-p "/tmp/a.docx")) + (should-not (cj/--video-file-p nil))) + +;;; cj/--video-open-arglist + +(ert-deftest test-external-open-video-arglist-appends-file-after-args () + "Normal: the player args precede the file in the argument list." + (let ((cj/video-open-args '("--loop-file=inf"))) + (should (equal (cj/--video-open-arglist "/tmp/a.mp4") + '("--loop-file=inf" "/tmp/a.mp4"))))) + +(ert-deftest test-external-open-video-arglist-respects-custom-args () + "Boundary: custom args are honored; empty args yields just the file." + (let ((cj/video-open-args '("--loop=inf" "--mute=yes"))) + (should (equal (cj/--video-open-arglist "/tmp/a.mkv") + '("--loop=inf" "--mute=yes" "/tmp/a.mkv")))) + (let ((cj/video-open-args nil)) + (should (equal (cj/--video-open-arglist "/tmp/a.mkv") '("/tmp/a.mkv"))))) + +;;; cj/open-video-looping + +(ert-deftest test-external-open-video-looping-calls-player-with-loop-args () + "Normal: posix path calls the player with loop args + file, async (no wait)." + (let ((tmp (make-temp-file "test-ext-video-" nil ".mp4")) + (call nil)) + (unwind-protect + (cl-letf (((symbol-function 'env-windows-p) (lambda () nil)) + ((symbol-function 'call-process) + (lambda (prog _infile dest _disp &rest args) + (setq call (list prog dest args)) + 0))) + (let ((cj/video-open-command "mpv") + (cj/video-open-args '("--loop-file=inf"))) + (cj/open-video-looping tmp))) + (delete-file tmp)) + (should (equal (nth 0 call) "mpv")) + (should (equal (nth 1 call) 0)) ; async destination: don't wait + (should (member "--loop-file=inf" (nth 2 call))) + (should (cl-find-if (lambda (a) (and (stringp a) + (string-match-p "\\.mp4\\'" a))) + (nth 2 call))))) + +(ert-deftest test-external-open-video-looping-errors-when-no-file () + "Error: a buffer with no associated file signals user-error." + (with-temp-buffer + (cl-letf (((symbol-function 'cj/file-from-context) (lambda (_) nil))) + (should-error (cj/open-video-looping) :type 'user-error)))) + (provide 'test-external-open-commands) ;;; test-external-open-commands.el ends here diff --git a/tests/test-face-diagnostic.el b/tests/test-face-diagnostic.el new file mode 100644 index 000000000..32595b464 --- /dev/null +++ b/tests/test-face-diagnostic.el @@ -0,0 +1,357 @@ +;;; test-face-diagnostic.el --- Tests for the Phase 1 face-diagnosis core -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the pure read model of the face/font diagnostic (Phase 1): +;; buffer classification, character context, and the face stack separated by +;; source. All against temp-buffer fixtures with planted text properties, +;; overlays, and face remaps -- no display, no prompts. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'face-diagnostic) + +;;; cj/--face-diag-classify-buffer + +(ert-deftest test-face-diag-classify-theme-faced () + "Normal: an ordinary buffer classifies as theme-faced." + (with-temp-buffer + (fundamental-mode) + (should (eq (cj/--face-diag-classify-buffer) 'theme-faced)))) + +(ert-deftest test-face-diag-classify-terminal () + "Boundary: a terminal-family mode classifies as terminal-ansi." + (with-temp-buffer + (setq major-mode 'term-mode) + (should (eq (cj/--face-diag-classify-buffer) 'terminal-ansi)))) + +(ert-deftest test-face-diag-classify-document () + "Boundary: an shr-rendering mode classifies as document-shr." + (with-temp-buffer + (setq major-mode 'eww-mode) + (should (eq (cj/--face-diag-classify-buffer) 'document-shr)))) + +(ert-deftest test-face-diag-classify-image () + "Boundary: an image/document-view mode classifies as image-no-text." + (with-temp-buffer + (setq major-mode 'image-mode) + (should (eq (cj/--face-diag-classify-buffer) 'image-no-text)))) + +;;; cj/--face-diag-char-context + +(ert-deftest test-face-diag-char-context-normal () + "Normal: an ASCII letter reports char, codepoint, name, and script." + (with-temp-buffer + (insert "A") + (let ((ctx (cj/--face-diag-char-context (point-min)))) + (should (= (plist-get ctx :char) ?A)) + (should (= (plist-get ctx :codepoint) 65)) + (should (equal (plist-get ctx :name) "LATIN CAPITAL LETTER A")) + (should (eq (plist-get ctx :script) 'latin))))) + +(ert-deftest test-face-diag-char-context-eob-nil () + "Boundary/Error: end of an empty buffer has no character, so nil." + (with-temp-buffer + (should-not (cj/--face-diag-char-context (point-max))))) + +;;; cj/--face-diag-normalize-faces + +(ert-deftest test-face-diag-normalize-faces () + "Normal/Boundary: symbol, list, anonymous spec, and nil normalize correctly." + (should (equal (cj/--face-diag-normalize-faces 'bold) '(bold))) + (should (equal (cj/--face-diag-normalize-faces '(bold italic)) '(bold italic))) + (should (equal (cj/--face-diag-normalize-faces '(:foreground "red")) + '((:foreground "red")))) + (should-not (cj/--face-diag-normalize-faces nil))) + +;;; cj/--face-diag-text-property-faces + +(ert-deftest test-face-diag-text-property-faces-symbol () + "Normal: a `face' property symbol appears in the list." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (should (equal (cj/--face-diag-text-property-faces (point-min)) '(bold))))) + +(ert-deftest test-face-diag-text-property-faces-includes-font-lock () + "Normal: `face' and `font-lock-face' are both collected, face first." + (with-temp-buffer + (insert (propertize "x" 'face 'bold 'font-lock-face 'italic)) + (should (equal (cj/--face-diag-text-property-faces (point-min)) '(bold italic))))) + +(ert-deftest test-face-diag-text-property-faces-none () + "Boundary: unpropertized text yields no faces." + (with-temp-buffer + (insert "x") + (should-not (cj/--face-diag-text-property-faces (point-min))))) + +;;; cj/--face-diag-overlay-faces + +(ert-deftest test-face-diag-overlay-faces-sorted-by-priority () + "Normal: overlay faces are returned highest priority first." + (with-temp-buffer + (insert "xyz") + (let ((lo (make-overlay 1 3)) + (hi (make-overlay 1 3))) + (overlay-put lo 'face 'region) + (overlay-put lo 'priority 1) + (overlay-put hi 'face 'highlight) + (overlay-put hi 'priority 10) + (let ((entries (cj/--face-diag-overlay-faces 1))) + (should (= (length entries) 2)) + (should (eq (plist-get (car entries) :face) 'highlight)) + (should (eq (plist-get (cadr entries) :face) 'region)))))) + +(ert-deftest test-face-diag-overlay-faces-skips-faceless () + "Boundary: an overlay without a `face' property is excluded." + (with-temp-buffer + (insert "xyz") + (let ((ov (make-overlay 1 3))) + (overlay-put ov 'help-echo "no face here") + (should-not (cj/--face-diag-overlay-faces 1))))) + +;;; cj/--face-diag-active-remaps + +(ert-deftest test-face-diag-active-remaps-matches-stack () + "Normal: a remap of a stack face is returned; an unrelated remap is not." + (with-temp-buffer + (setq face-remapping-alist '((default :background "#111111") + (link :foreground "#222222"))) + (let ((remaps (cj/--face-diag-active-remaps '(default)))) + (should (assq 'default remaps)) + (should-not (assq 'link remaps))))) + +(ert-deftest test-face-diag-active-remaps-empty () + "Boundary: no remapping alist yields no entries." + (with-temp-buffer + (setq face-remapping-alist nil) + (should-not (cj/--face-diag-active-remaps '(default))))) + +;;; cj/--face-diag-stack + +(ert-deftest test-face-diag-stack-assembles-sources () + "Normal: the stack carries text-property, overlay, remap, and default sources." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (setq face-remapping-alist '((default :background "#111111"))) + (let ((ov (make-overlay 1 2))) + (overlay-put ov 'face 'region) + (let ((stack (cj/--face-diag-stack 1))) + (should (equal (plist-get stack :text-property) '(bold))) + (should (eq (plist-get (car (plist-get stack :overlays)) :face) 'region)) + (should (assq 'default (plist-get stack :remaps))) + (should (eq (plist-get stack :default) 'default)))))) + +;;; cj/--face-diagnosis-at + +(ert-deftest test-face-diagnosis-at-shape () + "Normal: the assembled core returns classification, char, and stack." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "A" 'face 'bold)) + (let ((diag (cj/--face-diagnosis-at (point-min)))) + (should (eq (plist-get diag :classification) 'theme-faced)) + (should (= (plist-get (plist-get diag :char) :char) ?A)) + (should (equal (plist-get (plist-get diag :stack) :text-property) '(bold)))))) + +(ert-deftest test-face-diagnosis-at-eob-char-nil () + "Boundary: at end of an empty buffer the char group is nil, stack still present." + (with-temp-buffer + (fundamental-mode) + (let ((diag (cj/--face-diagnosis-at (point-max)))) + (should-not (plist-get diag :char)) + (should (eq (plist-get (plist-get diag :stack) :default) 'default))))) + +;;; cj/--face-diag-merged-attributes + +(ert-deftest test-face-diag-merged-explicit-text-prop () + "Normal: an explicit text-property attribute is the winning merged value." + (with-temp-buffer + (insert (propertize "x" 'face '(:foreground "#abcdef" :weight bold))) + (let ((attrs (cj/--face-diag-merged-attributes (point-min)))) + (should (equal (plist-get attrs :foreground) "#abcdef")) + (should (eq (plist-get attrs :weight) 'bold))))) + +(ert-deftest test-face-diag-merged-overlay-wins-over-text-prop () + "Normal: a higher-priority overlay attribute beats the text-property face." + (with-temp-buffer + (insert (propertize "x" 'face '(:foreground "blue"))) + (let ((ov (make-overlay 1 2))) + (overlay-put ov 'face '(:foreground "red")) + (overlay-put ov 'priority 10) + (should (equal (plist-get (cj/--face-diag-merged-attributes 1) :foreground) + "red"))))) + +(ert-deftest test-face-diag-merged-applies-default-remap () + "Normal: a remap of the default face shows up in the merged attributes." + (with-temp-buffer + (insert "x") + (setq face-remapping-alist '((default :foreground "#123456"))) + (should (equal (plist-get (cj/--face-diag-merged-attributes 1) :foreground) + "#123456")))) + +(ert-deftest test-face-diag-merged-bold-face-symbol () + "Boundary: a face symbol in the stack contributes its set attributes." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (should (eq (plist-get (cj/--face-diag-merged-attributes 1) :weight) 'bold)))) + +;;; cj/--face-diag-real-font + +(ert-deftest test-face-diag-real-font-unavailable-in-batch () + "Boundary: font-at is nil under batch, so the real font reads \"unavailable\"." + (with-temp-buffer + (insert "x") + (let ((font (cj/--face-diag-real-font 1))) + (should (equal (plist-get font :font) "unavailable")) + (should-not (plist-get font :family))))) + +;;; cj/--face-diagnosis-at (groups 0-4) + +(ert-deftest test-face-diagnosis-at-includes-attributes-and-font () + "Normal: the assembled core carries the merged attributes and font groups." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "x" 'face '(:foreground "#abcdef"))) + (let ((diag (cj/--face-diagnosis-at (point-min)))) + (should (equal (plist-get (plist-get diag :attributes) :foreground) "#abcdef")) + (should (equal (plist-get (plist-get diag :font) :font) "unavailable"))))) + +;;; provenance accessors + +(ert-deftest test-face-diag-face-themes () + "Normal: theme names come from the face's theme-face property, newest first." + (make-face 'fd-test-themed) + (put 'fd-test-themed 'theme-face '((user spec1) (dupre spec2))) + (should (equal (cj/--face-diag-face-themes 'fd-test-themed) '(user dupre)))) + +(ert-deftest test-face-diag-config-source () + "Normal/Boundary: saved-face -> saved, customized-face -> customized, else nil." + (make-face 'fd-test-saved) + (put 'fd-test-saved 'saved-face '(spec)) + (make-face 'fd-test-cust) + (put 'fd-test-cust 'customized-face '(spec)) + (make-face 'fd-test-plain) + (should (eq (cj/--face-diag-config-source 'fd-test-saved) 'saved)) + (should (eq (cj/--face-diag-config-source 'fd-test-cust) 'customized)) + (should-not (cj/--face-diag-config-source 'fd-test-plain))) + +(ert-deftest test-face-diag-inherit-chain () + "Normal: a single-symbol :inherit produces a nearest-first chain." + (make-face 'fd-test-parent) + (make-face 'fd-test-child) + (set-face-attribute 'fd-test-child nil :inherit 'fd-test-parent) + (should (equal (cj/--face-diag-inherit-chain 'fd-test-child) '(fd-test-parent)))) + +(ert-deftest test-face-diag-inherit-chain-none () + "Boundary: a face with no :inherit has an empty chain." + (make-face 'fd-test-noinherit) + (should-not (cj/--face-diag-inherit-chain 'fd-test-noinherit))) + +(ert-deftest test-face-diag-unspecified-attrs () + "Normal: a bare face leaves attributes unspecified, so they fall to default." + (make-face 'fd-test-bare) + (should (memq :foreground (cj/--face-diag-unspecified-attrs 'fd-test-bare)))) + +(ert-deftest test-face-diag-provenance-covers-stack-and-default () + "Normal: provenance covers the stack's named faces and always the default." + (with-temp-buffer + (insert (propertize "x" 'face 'bold)) + (let ((faces (mapcar (lambda (p) (plist-get p :face)) + (cj/--face-diag-provenance (point-min))))) + (should (memq 'bold faces)) + (should (memq 'default faces))))) + +(ert-deftest test-face-diagnosis-at-includes-provenance () + "Normal: the assembled core carries the provenance group for stack faces." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "x" 'face 'bold)) + (let ((prov (plist-get (cj/--face-diagnosis-at (point-min)) :provenance))) + (should (cl-some (lambda (p) (eq (plist-get p :face) 'bold)) prov))))) + +;;; cj/--face-diag-render + +(ert-deftest test-face-diag-render-has-all-groups () + "Normal: the rendered report names every group and the stack's face." + (with-temp-buffer + (fundamental-mode) + (insert (propertize "A" 'face 'bold)) + (let ((report (cj/--face-diag-render (cj/--face-diagnosis-at (point-min))))) + (should (string-match-p "Character:" report)) + (should (string-match-p "Face stack" report)) + (should (string-match-p "bold" report)) + (should (string-match-p "Effective attributes" report)) + (should (string-match-p "Real font" report)) + (should (string-match-p "Provenance" report))))) + +(ert-deftest test-face-diag-face-button-real-face-is-button () + "Normal: a real face renders as a `describe-face' button carrying the face. +Visible label is unchanged; the button data is the face so RET/mouse opens it." + (let ((s (cj/--face-diag-face-button 'bold))) + (should (equal (substring-no-properties s) "bold")) + (should (get-text-property 0 'button s)) + (should (eq (get-text-property 0 'button-data s) 'bold)))) + +(ert-deftest test-face-diag-face-button-non-face-is-plain () + "Boundary: a symbol that is not a face stays plain text, no button." + (let ((s (cj/--face-diag-face-button 'cj-not-a-real-face-xyz))) + (should (equal s "cj-not-a-real-face-xyz")) + (should-not (get-text-property 0 'button s)))) + +(ert-deftest test-face-diag-face-button-anonymous-spec-is-plain () + "Error: an anonymous (:attr val ...) spec is not a face, so no button." + (let ((s (cj/--face-diag-face-button '(:foreground "red")))) + (should-not (get-text-property 0 'button s)))) + +(ert-deftest test-face-diag-render-faces-buttonizes-real-face () + "Normal: a real face in the stack render carries a button property." + (let ((s (cj/--face-diag-render-faces '(bold)))) + (should (string-match-p "bold" s)) + (should (get-text-property 0 'button s)))) + +(ert-deftest test-face-diag-render-banner-out-of-scope () + "Boundary: a terminal classification renders a banner naming the ANSI source." + (should (string-match-p "terminal" (cj/--face-diag-render-banner 'terminal-ansi))) + (should (equal (cj/--face-diag-render-banner 'theme-faced) ""))) + +(ert-deftest test-face-diag-render-no-char () + "Boundary: a nil char group renders the no-character notice." + (should (string-match-p "none at point" (cj/--face-diag-render-char nil)))) + +(ert-deftest test-face-diag-render-region-covers-runs () + "Normal: region rendering emits a position header per distinct face-run." + (with-temp-buffer + (insert (propertize "aa" 'face 'bold)) + (insert (propertize "bb" 'face 'italic)) + (let ((report (cj/--face-diag-render-region (point-min) (point-max)))) + (should (string-match-p "=== position 1 ===" report)) + (should (string-match-p "=== position 3 ===" report))))) + +;;; cj/describe-face-at-point (smoke) + +(ert-deftest test-face-diag-command-creates-buffer () + "Normal: the command renders into the read-only *Face Diagnosis* buffer." + (with-temp-buffer + (insert (propertize "A" 'face 'bold)) + (goto-char (point-min)) + (cj/describe-face-at-point) + (let ((buf (get-buffer "*Face Diagnosis*"))) + (unwind-protect + (progn + (should buf) + (with-current-buffer buf + (should (eq major-mode 'cj/face-diagnostic-mode)) + (should buffer-read-only) + (should (string-match-p "Face stack" (buffer-string))))) + (when (buffer-live-p buf) (kill-buffer buf)))))) + +;;; keybinding + +(ert-deftest test-face-diag-bound-on-c-h-F () + "Normal: loading the module binds C-h F to the diagnostic command." + (should (eq (keymap-lookup help-map "F") 'cj/describe-face-at-point))) + +(provide 'test-face-diagnostic) +;;; test-face-diagnostic.el ends here diff --git a/tests/test-flyspell-and-abbrev.el b/tests/test-flyspell-and-abbrev.el index 793fdc0f4..ef8cc6375 100644 --- a/tests/test-flyspell-and-abbrev.el +++ b/tests/test-flyspell-and-abbrev.el @@ -32,12 +32,12 @@ (ert-deftest test-flyspell-require-spell-checker-present () "Normal: a checker on PATH means no error." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (equal cmd (car cj/--spell-checker-executables))))) + (lambda (cmd &rest _) (equal cmd (car cj/--spell-checker-executables))))) (should-not (cj/--require-spell-checker)))) (ert-deftest test-flyspell-require-spell-checker-missing () "Error: no checker on PATH signals user-error." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/--require-spell-checker) :type 'user-error))) ;; --------------------- cj/find-previous-flyspell-overlay --------------------- diff --git a/tests/test-font-config--frame-lifecycle.el b/tests/test-font-config--frame-lifecycle.el new file mode 100644 index 000000000..826edbd69 --- /dev/null +++ b/tests/test-font-config--frame-lifecycle.el @@ -0,0 +1,75 @@ +;;; test-font-config--frame-lifecycle.el --- Tests for the lifted font frame helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/apply-font-settings-to-frame, cj/cleanup-frame-list, and +;; cj/maybe-install-all-the-icons-fonts were defined inside use-package +;; :config / with-eval-after-load (unreachable under `make test'). Lifting +;; them to top level makes their branching unit-testable; env-gui-p and the +;; package side-effect calls are mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'font-config) + +(defvar cj/fontaine-configured-frames) + +(ert-deftest test-font-cleanup-frame-list-removes-frame () + "Normal: cleanup drops the given frame from the configured list." + (let ((cj/fontaine-configured-frames '(fr1 fr2 fr3))) + (cj/cleanup-frame-list 'fr2) + (should (equal cj/fontaine-configured-frames '(fr1 fr3))))) + +(ert-deftest test-font-apply-gui-unconfigured-sets-preset () + "Normal: a GUI frame not yet configured gets the preset and is tracked." + (let ((cj/fontaine-configured-frames nil) + (called nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) + (cj/apply-font-settings-to-frame (selected-frame))) + (should called) + (should (member (selected-frame) cj/fontaine-configured-frames)))) + +(ert-deftest test-font-apply-already-configured-is-noop () + "Boundary: an already-configured frame is not re-preset." + (let ((cj/fontaine-configured-frames (list (selected-frame))) + (called nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) + (cj/apply-font-settings-to-frame (selected-frame))) + (should-not called))) + +(ert-deftest test-font-apply-non-gui-is-noop () + "Boundary: without a GUI nothing is applied or tracked." + (let ((cj/fontaine-configured-frames nil) + (called nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () nil)) + ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) + (cj/apply-font-settings-to-frame (selected-frame))) + (should-not called) + (should-not (member (selected-frame) cj/fontaine-configured-frames)))) + +(ert-deftest test-font-maybe-install-icons-gui-missing-installs () + "Normal: GUI present and font missing triggers the install." + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_n) nil)) + ((symbol-function 'all-the-icons-install-fonts) (lambda (&rest _) (setq installed t))) + ((symbol-function 'remove-hook) #'ignore)) + (cj/maybe-install-all-the-icons-fonts)) + (should installed))) + +(ert-deftest test-font-maybe-install-icons-already-present-skips () + "Boundary: an installed font means no install attempt." + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_n) t)) + ((symbol-function 'all-the-icons-install-fonts) (lambda (&rest _) (setq installed t)))) + (cj/maybe-install-all-the-icons-fonts)) + (should-not installed))) + +(provide 'test-font-config--frame-lifecycle) +;;; test-font-config--frame-lifecycle.el ends here diff --git a/tests/test-google-keep-config.el b/tests/test-google-keep-config.el new file mode 100644 index 000000000..690355506 --- /dev/null +++ b/tests/test-google-keep-config.el @@ -0,0 +1,142 @@ +;;; test-google-keep-config.el --- Tests for google-keep-config -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the pure JSON-to-org core of google-keep-config.el (the part that +;; later extracts to a package) plus the parse-render-write chain. The bridge +;; subprocess + auth are the IO boundary, exercised live once the token is set. + +;;; Code: + +(require 'ert) +(require 'google-keep-config) + +(defun test-google-keep--note (&rest overrides) + "Build a note alist (parse-shaped) with OVERRIDES merged in." + (let ((base (list (cons 'id "abc") + (cons 'title "Groceries") + (cons 'text "milk\neggs") + (cons 'labels '("shopping" "home")) + (cons 'pinned nil) + (cons 'archived nil) + (cons 'color "WHITE") + (cons 'updated "2026-06-25T04:00:00Z")))) + (dolist (pair overrides base) + (setf (alist-get (car pair) base) (cdr pair))))) + +;;; cj/keep--parse-json + +(ert-deftest test-google-keep-parse-json-array () + "Normal: a JSON array parses to a list of note alists." + (let ((notes (cj/keep--parse-json + "[{\"id\":\"a\",\"title\":\"T\",\"labels\":[\"x\"],\"pinned\":true}]"))) + (should (= 1 (length notes))) + (should (equal "a" (alist-get 'id (car notes)))) + (should (equal '("x") (alist-get 'labels (car notes)))) + (should (eq t (alist-get 'pinned (car notes)))))) + +(ert-deftest test-google-keep-parse-json-empty () + "Boundary: an empty Keep ([]) parses to an empty list." + (should (null (cj/keep--parse-json "[]")))) + +;;; cj/keep--label-to-tag + +(ert-deftest test-google-keep-label-to-tag-plain () + "Normal: an alphanumeric label is unchanged." + (should (equal "shopping" (cj/keep--label-to-tag "shopping")))) + +(ert-deftest test-google-keep-label-to-tag-sanitizes () + "Boundary: spaces and punctuation become underscores (valid org tag chars)." + (should (equal "to_do_list_" (cj/keep--label-to-tag "to do/list!")))) + +;;; cj/keep--note-tags + +(ert-deftest test-google-keep-note-tags-labels () + "Normal: labels render as a trailing org-tag string." + (should (equal " :shopping:home:" (cj/keep--note-tags (test-google-keep--note))))) + +(ert-deftest test-google-keep-note-tags-archived () + "Normal: an archived note gains the archived tag." + (should (equal " :shopping:home:archived:" + (cj/keep--note-tags (test-google-keep--note (cons 'archived t)))))) + +(ert-deftest test-google-keep-note-tags-none () + "Boundary: no labels and not archived yields an empty tag string." + (should (equal "" (cj/keep--note-tags + (test-google-keep--note (cons 'labels nil)))))) + +;;; cj/keep--note-heading + +(ert-deftest test-google-keep-note-heading-full () + "Normal: a full note renders heading, properties, link, and body." + (let ((s (cj/keep--note-heading (test-google-keep--note)))) + (should (string-match-p "\\`\\* Groceries :shopping:home:\n" s)) + (should (string-match-p ":KEEP_ID: abc\n" s)) + (should (string-match-p ":UPDATED: 2026-06-25T04:00:00Z\n" s)) + (should (string-match-p "\\[\\[https://keep.google.com/#NOTE/abc\\]\\[open in Keep\\]\\]" s)) + (should (string-match-p "milk\neggs\n" s)))) + +(ert-deftest test-google-keep-note-heading-untitled () + "Boundary: an empty title falls back to (untitled)." + (let ((s (cj/keep--note-heading (test-google-keep--note (cons 'title ""))))) + (should (string-match-p "\\`\\* (untitled)" s)))) + +(ert-deftest test-google-keep-note-heading-empty-text () + "Boundary: an empty body emits no trailing text block." + (let ((s (cj/keep--note-heading + (test-google-keep--note (cons 'text "") (cons 'labels nil))))) + (should-not (string-match-p "open in Keep\\]\\]\n.+[^\n]" s)))) + +;;; cj/keep--sort-pinned-first + +(ert-deftest test-google-keep-sort-pinned-first () + "Normal: pinned notes come first, order otherwise preserved." + (let* ((a (test-google-keep--note (cons 'id "a") (cons 'pinned nil))) + (b (test-google-keep--note (cons 'id "b") (cons 'pinned t))) + (c (test-google-keep--note (cons 'id "c") (cons 'pinned nil))) + (sorted (cj/keep--sort-pinned-first (list a b c)))) + (should (equal '("b" "a" "c") (mapcar (lambda (n) (alist-get 'id n)) sorted))))) + +;;; cj/keep--render + +(ert-deftest test-google-keep-render-header-and-notes () + "Normal: the page carries the read-only header and a heading per note." + (let ((s (cj/keep--render (list (test-google-keep--note)) "2026-06-25 04:00"))) + (should (string-match-p "read-only view" s)) + (should (string-match-p "Last refresh: 2026-06-25 04:00" s)) + (should (string-match-p "^\\* Groceries" s)))) + +(ert-deftest test-google-keep-render-empty () + "Boundary: no notes still produces a valid header-only page." + (let ((s (cj/keep--render nil))) + (should (string-match-p "#\\+TITLE: Google Keep" s)) + (should-not (string-match-p "^\\* " s)))) + +;;; cj/keep--write-atomically + the parse-render-write chain + +(ert-deftest test-google-keep-write-atomically () + "Normal: content lands in the target file via temp + rename." + (let* ((dir (make-temp-file "keep-test-" t)) + (file (expand-file-name "keep.org" dir))) + (unwind-protect + (progn + (cj/keep--write-atomically "hello\n" file) + (should (equal "hello\n" + (with-temp-buffer (insert-file-contents file) + (buffer-string))))) + (delete-directory dir t)))) + +(ert-deftest test-google-keep-write-notes-chain () + "Normal: JSON in, a rendered org file out, with the note count returned." + (let* ((dir (make-temp-file "keep-test-" t)) + (keep-file (expand-file-name "keep.org" dir))) + (unwind-protect + (let ((n (cj/keep--write-notes + "[{\"id\":\"a\",\"title\":\"One\",\"labels\":[],\"pinned\":false,\"archived\":false,\"color\":\"WHITE\",\"updated\":\"2026-06-25T04:00:00Z\"}]"))) + (should (= 1 n)) + (should (string-match-p "^\\* One" + (with-temp-buffer (insert-file-contents keep-file) + (buffer-string))))) + (delete-directory dir t)))) + +(provide 'test-google-keep-config) +;;; test-google-keep-config.el ends here diff --git a/tests/test-gptel-tools-git-diff.el b/tests/test-gptel-tools-git-diff.el deleted file mode 100644 index 114fec293..000000000 --- a/tests/test-gptel-tools-git-diff.el +++ /dev/null @@ -1,163 +0,0 @@ -;;; test-gptel-tools-git-diff.el --- Tests for git_diff gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests run against real temp git repos under HOME via `process-file'. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'git_diff) - -;; ---------- helpers - -(defun test-gptel-tools-git-diff--with-repo (fn) - "Create a temp git repo under HOME with one committed file, call FN." - (let* ((name (format ".test-gptel-tools-git-diff-%s" - (format-time-string "%s%N"))) - (dir (expand-file-name name "~"))) - (unwind-protect - (progn - (make-directory dir) - (let ((default-directory dir)) - (call-process "git" nil nil nil "init" "--quiet") - (call-process "git" nil nil nil "config" "user.email" "test@x") - (call-process "git" nil nil nil "config" "user.name" "Test") - (with-temp-file (expand-file-name "f.txt" dir) - (insert "original\n")) - (call-process "git" nil nil nil "add" "f.txt") - (call-process "git" nil nil nil "commit" "--quiet" "-m" "initial")) - (funcall fn dir)) - (when (file-exists-p dir) (delete-directory dir t))))) - -;; ---------- build-args - -(ert-deftest test-gptel-tools-git-diff-build-args-no-refs () - "Normal: no refs / no file → bare diff args." - (should (equal (cj/gptel-git-diff--build-args nil nil nil) - '("-c" "color.ui=false" "diff")))) - -(ert-deftest test-gptel-tools-git-diff-build-args-with-ref1 () - "Normal: REF1 appended." - (should (equal (cj/gptel-git-diff--build-args "HEAD~1" nil nil) - '("-c" "color.ui=false" "diff" "HEAD~1")))) - -(ert-deftest test-gptel-tools-git-diff-build-args-with-both-refs () - "Normal: REF1 and REF2 both appended." - (should (equal (cj/gptel-git-diff--build-args "HEAD~1" "HEAD" nil) - '("-c" "color.ui=false" "diff" "HEAD~1" "HEAD")))) - -(ert-deftest test-gptel-tools-git-diff-build-args-with-file () - "Normal: FILE appended after `--'." - (should (equal (cj/gptel-git-diff--build-args nil nil "foo.txt") - '("-c" "color.ui=false" "diff" "--" "foo.txt")))) - -(ert-deftest test-gptel-tools-git-diff-build-args-boundary-empty-strings () - "Boundary: empty-string REF/FILE values are ignored." - (should (equal (cj/gptel-git-diff--build-args "" "" "") - '("-c" "color.ui=false" "diff")))) - -;; ---------- truncate - -(ert-deftest test-gptel-tools-git-diff-truncate-under-cap () - "Normal: short input returns unchanged." - (should (equal (cj/gptel-git-diff--truncate "small diff") "small diff"))) - -(ert-deftest test-gptel-tools-git-diff-truncate-over-cap () - "Boundary: output exceeding the cap is truncated with a marker." - (let* ((cap cj/gptel-git-diff--max-output-bytes) - (huge (make-string (+ cap 1000) ?x)) - (out (cj/gptel-git-diff--truncate huge))) - (should (string-match-p "\\[truncated:" out)) - (should (> (length huge) (length out))))) - -;; ---------- validate-path - -(ert-deftest test-gptel-tools-git-diff-validate-path-normal () - "Normal: validator accepts a git working tree." - (test-gptel-tools-git-diff--with-repo - (lambda (dir) - (should (equal (cj/gptel-git-diff--validate-path dir) dir))))) - -(ert-deftest test-gptel-tools-git-diff-validate-path-error-outside-home () - "Error: path outside HOME signals." - (should-error (cj/gptel-git-diff--validate-path "/etc"))) - -(ert-deftest test-gptel-tools-git-diff-validate-path-error-not-a-repo () - "Error: non-git directory signals." - (let ((dir (make-temp-file - (expand-file-name ".test-gptel-tools-git-diff-" "~") t))) - (unwind-protect - (should-error (cj/gptel-git-diff--validate-path dir)) - (when (file-exists-p dir) (delete-directory dir t))))) - -(ert-deftest test-gptel-tools-git-diff-validate-path-error-not-a-directory () - "Error: file paths are rejected." - (let ((file (make-temp-file - (expand-file-name ".test-gptel-tools-git-diff-file-" "~")))) - (unwind-protect - (should-error (cj/gptel-git-diff--validate-path file)) - (when (file-exists-p file) (delete-file file))))) - -(ert-deftest test-gptel-tools-git-diff-validate-path-error-symlink-outside-home () - "Error: symlinked directories resolving outside HOME are rejected." - (let ((link (expand-file-name - (format ".test-gptel-tools-git-diff-link-%s" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link "/tmp" link t) - (should-error (cj/gptel-git-diff--validate-path link))) - (when (file-symlink-p link) (delete-file link))))) - -;; ---------- run - -(ert-deftest test-gptel-tools-git-diff-run-no-changes () - "Boundary: a clean tree with no refs returns the no-diff marker." - (test-gptel-tools-git-diff--with-repo - (lambda (dir) - (let ((out (cj/gptel-git-diff--run dir))) - (should (string-match-p "No diff" out)))))) - -(ert-deftest test-gptel-tools-git-diff-run-unstaged-change () - "Normal: an unstaged edit appears as a real diff." - (test-gptel-tools-git-diff--with-repo - (lambda (dir) - (with-temp-file (expand-file-name "f.txt" dir) - (insert "changed\n")) - (let ((out (cj/gptel-git-diff--run dir))) - (should (string-match-p "^-original" out)) - (should (string-match-p "^\\+changed" out)))))) - -(ert-deftest test-gptel-tools-git-diff-run-narrow-to-file () - "Normal: FILE argument narrows the diff." - (test-gptel-tools-git-diff--with-repo - (lambda (dir) - (with-temp-file (expand-file-name "f.txt" dir) - (insert "changed\n")) - (with-temp-file (expand-file-name "g.txt" dir) - (insert "second file\n")) - (let ((out (cj/gptel-git-diff--run dir nil nil "f.txt"))) - (should (string-match-p "f.txt" out)) - (should-not (string-match-p "g.txt" out)))))) - -(ert-deftest test-gptel-tools-git-diff-run-error-on-bad-ref () - "Error: git diff exits other than 0/1 are surfaced." - (test-gptel-tools-git-diff--with-repo - (lambda (dir) - (should-error (cj/gptel-git-diff--run dir "does-not-exist"))))) - -(provide 'test-gptel-tools-git-diff) -;;; test-gptel-tools-git-diff.el ends here diff --git a/tests/test-gptel-tools-git-log.el b/tests/test-gptel-tools-git-log.el deleted file mode 100644 index c0503039a..000000000 --- a/tests/test-gptel-tools-git-log.el +++ /dev/null @@ -1,183 +0,0 @@ -;;; test-gptel-tools-git-log.el --- Tests for git_log gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests run against real temp git repos under HOME via `process-file'. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'git_log) - -;; ---------- helpers - -(defun test-gptel-tools-git-log--with-repo (commit-count fn) - "Create a temp git repo under HOME with COMMIT-COUNT empty commits. -Call FN with the absolute path, clean up after." - (let* ((name (format ".test-gptel-tools-git-log-%s" - (format-time-string "%s%N"))) - (dir (expand-file-name name "~"))) - (unwind-protect - (progn - (make-directory dir) - (let ((default-directory dir)) - (call-process "git" nil nil nil "init" "--quiet") - (call-process "git" nil nil nil "config" "user.email" "test@x") - (call-process "git" nil nil nil "config" "user.name" "Test") - (dotimes (i commit-count) - (let ((process-environment - (append - (list "GIT_AUTHOR_DATE=2000-01-01T00:00:00+0000" - "GIT_COMMITTER_DATE=2000-01-01T00:00:00+0000") - process-environment))) - (call-process "git" nil nil nil "commit" "--allow-empty" - "--quiet" "-m" (format "commit %d" i))))) - (funcall fn dir)) - (when (file-exists-p dir) (delete-directory dir t))))) - -;; ---------- effective-count - -(ert-deftest test-gptel-tools-git-log-effective-count-defaults-on-nil () - "Boundary: nil N → default count." - (should (= (cj/gptel-git-log--effective-count nil) - cj/gptel-git-log--default-count))) - -(ert-deftest test-gptel-tools-git-log-effective-count-defaults-on-non-integer () - "Boundary: non-integer N → default count." - (should (= (cj/gptel-git-log--effective-count "ten") - cj/gptel-git-log--default-count)) - (should (= (cj/gptel-git-log--effective-count 0.5) - cj/gptel-git-log--default-count))) - -(ert-deftest test-gptel-tools-git-log-effective-count-clamps-low () - "Boundary: N below 1 → default count." - (should (= (cj/gptel-git-log--effective-count 0) - cj/gptel-git-log--default-count)) - (should (= (cj/gptel-git-log--effective-count -5) - cj/gptel-git-log--default-count))) - -(ert-deftest test-gptel-tools-git-log-effective-count-caps-high () - "Boundary: N above max → max." - (should (= (cj/gptel-git-log--effective-count 1000) - cj/gptel-git-log--max-count))) - -(ert-deftest test-gptel-tools-git-log-effective-count-normal () - "Normal: a valid N passes through." - (should (= (cj/gptel-git-log--effective-count 5) 5))) - -;; ---------- validate-path - -(ert-deftest test-gptel-tools-git-log-validate-path-normal () - "Normal: validator accepts a git working tree." - (test-gptel-tools-git-log--with-repo - 1 - (lambda (dir) - (should (equal (cj/gptel-git-log--validate-path dir) dir))))) - -(ert-deftest test-gptel-tools-git-log-validate-path-error-outside-home () - "Error: path outside HOME signals." - (should-error (cj/gptel-git-log--validate-path "/etc"))) - -(ert-deftest test-gptel-tools-git-log-validate-path-error-not-a-repo () - "Error: directory outside any git working tree signals." - (let ((dir (make-temp-file - (expand-file-name ".test-gptel-tools-git-log-" "~") t))) - (unwind-protect - (should-error (cj/gptel-git-log--validate-path dir)) - (when (file-exists-p dir) (delete-directory dir t))))) - -(ert-deftest test-gptel-tools-git-log-validate-path-error-not-a-directory () - "Error: file paths are rejected." - (let ((file (make-temp-file - (expand-file-name ".test-gptel-tools-git-log-file-" "~")))) - (unwind-protect - (should-error (cj/gptel-git-log--validate-path file)) - (when (file-exists-p file) (delete-file file))))) - -(ert-deftest test-gptel-tools-git-log-validate-path-error-symlink-outside-home () - "Error: symlinked directories resolving outside HOME are rejected." - (let ((link (expand-file-name - (format ".test-gptel-tools-git-log-link-%s" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link "/tmp" link t) - (should-error (cj/gptel-git-log--validate-path link))) - (when (file-symlink-p link) (delete-file link))))) - -;; ---------- run - -(ert-deftest test-gptel-tools-git-log-run-default-count () - "Normal: default count limits output to that many commits." - (test-gptel-tools-git-log--with-repo - 30 - (lambda (dir) - (let* ((out (cj/gptel-git-log--run dir)) - (lines (split-string (string-trim out) "\n"))) - (should (= (length lines) cj/gptel-git-log--default-count)))))) - -(ert-deftest test-gptel-tools-git-log-run-honors-n () - "Normal: an explicit N limits output to N commits." - (test-gptel-tools-git-log--with-repo - 10 - (lambda (dir) - (let* ((out (cj/gptel-git-log--run dir 3)) - (lines (split-string (string-trim out) "\n"))) - (should (= (length lines) 3)))))) - -(ert-deftest test-gptel-tools-git-log-run-since-no-match () - "Boundary: --since filter with no matching commits returns marker." - (test-gptel-tools-git-log--with-repo - 1 - (lambda (dir) - (let ((out (cj/gptel-git-log--run dir 10 "2001-01-01"))) - (should (string-match-p "No commits" out)))))) - -(ert-deftest test-gptel-tools-git-log-run-error-on-git-log-failure () - "Error: non-zero git log exits are surfaced." - (test-gptel-tools-git-log--with-repo - 1 - (lambda (dir) - (cl-letf (((symbol-function 'process-file) - (lambda (program infile destination display &rest args) - (if (member "log" args) - (progn - (when (bufferp destination) - (with-current-buffer destination (insert "bad log"))) - 2) - (apply #'call-process program infile destination display args))))) - (should-error (cj/gptel-git-log--run dir)))))) - -(ert-deftest test-gptel-tools-git-log-run-empty-repo () - "Boundary: a repo with no commits returns the empty-result marker." - (let* ((name (format ".test-gptel-tools-git-log-empty-%s" - (format-time-string "%s%N"))) - (dir (expand-file-name name "~"))) - (unwind-protect - (progn - (make-directory dir) - (let ((default-directory dir)) - (call-process "git" nil nil nil "init" "--quiet")) - ;; git log on a no-commits repo errors in some versions, but - ;; our wrapper turns "no commits" into the no-match marker. - (let ((res (ignore-errors (cj/gptel-git-log--run dir)))) - ;; Either path is acceptable: error captured (nil) or the - ;; explicit "No commits matching" marker. - (should (or (null res) - (string-match-p "No commits" res))))) - (when (file-exists-p dir) (delete-directory dir t))))) - -(provide 'test-gptel-tools-git-log) -;;; test-gptel-tools-git-log.el ends here diff --git a/tests/test-gptel-tools-git-status.el b/tests/test-gptel-tools-git-status.el deleted file mode 100644 index 471938535..000000000 --- a/tests/test-gptel-tools-git-status.el +++ /dev/null @@ -1,124 +0,0 @@ -;;; test-gptel-tools-git-status.el --- Tests for git_status gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests run against real temp git repos under HOME via `process-file'. -;; The tool is read-only so repos are torn down per test. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'git_status) - -;; ---------- helpers - -(defun test-gptel-tools-git-status--with-repo (fn) - "Create a temp git repo under HOME, call FN with its absolute path, clean up." - (let* ((name (format ".test-gptel-tools-git-status-%s" - (format-time-string "%s%N"))) - (dir (expand-file-name name "~"))) - (unwind-protect - (progn - (make-directory dir) - (let ((default-directory dir)) - (call-process "git" nil nil nil "init" "--quiet") - (call-process "git" nil nil nil "config" "user.email" "test@x") - (call-process "git" nil nil nil "config" "user.name" "Test") - (call-process "git" nil nil nil "commit" "--allow-empty" - "--quiet" "-m" "initial")) - (funcall fn dir)) - (when (file-exists-p dir) (delete-directory dir t))))) - -;; ---------- validate-path - -(ert-deftest test-gptel-tools-git-status-validate-path-normal () - "Normal: validator accepts a directory inside a git working tree." - (test-gptel-tools-git-status--with-repo - (lambda (dir) - (should (equal (cj/gptel-git-status--validate-path dir) dir))))) - -(ert-deftest test-gptel-tools-git-status-validate-path-error-outside-home () - "Error: path outside HOME signals." - (should-error (cj/gptel-git-status--validate-path "/etc"))) - -(ert-deftest test-gptel-tools-git-status-validate-path-error-not-a-directory () - "Error: path that's not a directory signals." - (let ((file (make-temp-file - (expand-file-name ".test-gptel-tools-git-status-" "~")))) - (unwind-protect - (should-error (cj/gptel-git-status--validate-path file)) - (when (file-exists-p file) (delete-file file))))) - -(ert-deftest test-gptel-tools-git-status-validate-path-error-not-a-repo () - "Error: directory outside any git working tree signals." - (let ((dir (make-temp-file - (expand-file-name ".test-gptel-tools-git-status-" "~") t))) - (unwind-protect - (should-error (cj/gptel-git-status--validate-path dir)) - (when (file-exists-p dir) (delete-directory dir t))))) - -(ert-deftest test-gptel-tools-git-status-validate-path-error-symlink-outside-home () - "Error: symlinked directories resolving outside HOME are rejected." - (let ((link (expand-file-name - (format ".test-gptel-tools-git-status-link-%s" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link "/tmp" link t) - (should-error (cj/gptel-git-status--validate-path link))) - (when (file-symlink-p link) (delete-file link))))) - -;; ---------- run - -(ert-deftest test-gptel-tools-git-status-run-clean-tree () - "Normal: a clean repo returns the clean-tree marker." - (test-gptel-tools-git-status--with-repo - (lambda (dir) - (let ((out (cj/gptel-git-status--run dir))) - (should (string-match-p "Clean working tree" out)))))) - -(ert-deftest test-gptel-tools-git-status-run-dirty-tree-includes-file () - "Normal: an untracked file appears in the output." - (test-gptel-tools-git-status--with-repo - (lambda (dir) - (with-temp-file (expand-file-name "new.txt" dir) (insert "x")) - (let ((out (cj/gptel-git-status--run dir))) - (should (string-match-p "new.txt" out)) - (should (string-match-p "^\\?\\?" out)))))) - -(ert-deftest test-gptel-tools-git-status-run-includes-branch () - "Normal: the `--branch' line surfaces in the output." - (test-gptel-tools-git-status--with-repo - (lambda (dir) - (with-temp-file (expand-file-name "f.txt" dir) (insert "x")) - (let ((out (cj/gptel-git-status--run dir))) - (should (string-match-p "^## " out)))))) - -(ert-deftest test-gptel-tools-git-status-run-error-on-git-status-failure () - "Error: non-zero git status exits are surfaced." - (test-gptel-tools-git-status--with-repo - (lambda (dir) - (cl-letf (((symbol-function 'process-file) - (lambda (program infile destination display &rest args) - (if (member "status" args) - (progn - (when (bufferp destination) - (with-current-buffer destination (insert "bad status"))) - 2) - (apply #'call-process program infile destination display args))))) - (should-error (cj/gptel-git-status--run dir)))))) - -(provide 'test-gptel-tools-git-status) -;;; test-gptel-tools-git-status.el ends here diff --git a/tests/test-gptel-tools-list-directory-files.el b/tests/test-gptel-tools-list-directory-files.el deleted file mode 100644 index 9588ce8be..000000000 --- a/tests/test-gptel-tools-list-directory-files.el +++ /dev/null @@ -1,257 +0,0 @@ -;;; test-gptel-tools-list-directory-files.el --- Tests for list_directory_files -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the helpers in list_directory_files.el. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'list_directory_files) - -;; -------------------------- helpers - -(defun test-gptel-tools-list--with-tree (fn) - "Create a small directory tree, call FN with its root, clean up." - (let ((root (make-temp-file "test-gptel-tools-list-" t))) - (unwind-protect - (progn - (with-temp-file (expand-file-name "a.txt" root) (insert "a")) - (with-temp-file (expand-file-name "b.org" root) (insert "b")) - (make-directory (expand-file-name "sub" root)) - (with-temp-file (expand-file-name "sub/c.txt" root) (insert "c")) - (funcall fn root)) - (delete-directory root t)))) - -;; -------------------------- mode-to-permissions - -(ert-deftest test-gptel-tools-list-mode-to-permissions-regular-file () - "Mode 0644 on a regular file: -rw-r--r--." - (should (equal (list-directory-files--mode-to-permissions #o0644) - "-rw-r--r--"))) - -(ert-deftest test-gptel-tools-list-mode-to-permissions-directory () - "Mode 0755 + dir bit: drwxr-xr-x." - (should (equal (list-directory-files--mode-to-permissions - (logior #o40000 #o0755)) - "drwxr-xr-x"))) - -(ert-deftest test-gptel-tools-list-mode-to-permissions-executable () - "Mode 0700: -rwx------." - (should (equal (list-directory-files--mode-to-permissions #o0700) - "-rwx------"))) - -;; -------------------------- get-file-info - -(ert-deftest test-gptel-tools-list-get-file-info-success () - "Success: returns a plist with :success t and metadata." - (test-gptel-tools-list--with-tree - (lambda (root) - (let ((info (list-directory-files--get-file-info - (expand-file-name "a.txt" root)))) - (should (plist-get info :success)) - (should (numberp (plist-get info :size))) - (should (stringp (plist-get info :permissions))))))) - -(ert-deftest test-gptel-tools-list-get-file-info-directory () - "Directory info: :is-directory is t." - (test-gptel-tools-list--with-tree - (lambda (root) - (let ((info (list-directory-files--get-file-info - (expand-file-name "sub" root)))) - (should (plist-get info :is-directory)))))) - -(ert-deftest test-gptel-tools-list-get-file-info-error () - "Error: metadata failures are returned as failed info plists." - (cl-letf (((symbol-function 'file-attributes) - (lambda (&rest _args) (error "stat failed")))) - (let ((info (list-directory-files--get-file-info "/tmp/nope"))) - (should-not (plist-get info :success)) - (should (string-match-p "stat failed" (plist-get info :error)))))) - -;; -------------------------- filter-by-extension - -(ert-deftest test-gptel-tools-list-filter-by-extension-keeps-match () - "Filter for txt keeps txt files." - (let* ((filter (list-directory-files--filter-by-extension "txt")) - (info '(:success t :path "/x/foo.txt" :is-directory nil))) - (should (funcall filter info)))) - -(ert-deftest test-gptel-tools-list-filter-by-extension-drops-non-match () - "Filter for txt drops non-txt files." - (let* ((filter (list-directory-files--filter-by-extension "txt")) - (info '(:success t :path "/x/foo.org" :is-directory nil))) - (should-not (funcall filter info)))) - -(ert-deftest test-gptel-tools-list-filter-by-extension-always-keeps-directories () - "Filter keeps directories regardless of extension." - (let* ((filter (list-directory-files--filter-by-extension "txt")) - (info '(:success t :path "/x/sub" :is-directory t))) - (should (funcall filter info)))) - -(ert-deftest test-gptel-tools-list-filter-by-extension-no-extension-is-nil () - "No extension produces a nil filter (i.e. no filtering)." - (should-not (list-directory-files--filter-by-extension nil))) - -(ert-deftest test-gptel-tools-list-filter-by-extension-case-insensitive () - "Boundary: extension filtering is case-insensitive." - (let* ((filter (list-directory-files--filter-by-extension "txt")) - (info '(:success t :path "/x/FOO.TXT" :is-directory nil))) - (should (funcall filter info)))) - -(ert-deftest test-gptel-tools-list-filter-by-extension-drops-failed-file-info () - "Boundary: failed file info entries do not pass file extension filters." - (let* ((filter (list-directory-files--filter-by-extension "txt")) - (info '(:success nil :path "/x/foo.txt" :is-directory nil))) - (should-not (funcall filter info)))) - -;; -------------------------- format-file-entry - -(ert-deftest test-gptel-tools-list-format-file-entry-shape () - "Formatted entry contains permissions, size, mtime, and relative path." - (let* ((info (list (cons :path "/home/u/foo.txt") - (cons :permissions "-rw-r--r--") - (cons :executable nil) - (cons :size 42) - (cons :last-modified (current-time)))) - ;; Build as plist by flattening the cons list. - (info-plist (cl-loop for (k . v) in info append (list k v))) - (out (list-directory-files--format-file-entry info-plist "/home/u"))) - (should (string-match-p "-rw-r--r--" out)) - (should (string-match-p "foo.txt" out)))) - -;; -------------------------- list-directory - -(ert-deftest test-gptel-tools-list-list-directory-flat () - "Non-recursive listing returns only entries in the top level." - (test-gptel-tools-list--with-tree - (lambda (root) - (let* ((result (list-directory-files--list-directory root nil nil)) - (files (plist-get result :files))) - (should files) - (let ((paths (mapcar (lambda (i) (plist-get i :path)) files))) - (should (cl-some (lambda (p) (string-match-p "/a\\.txt\\'" p)) paths)) - (should-not (cl-some (lambda (p) (string-match-p "/c\\.txt\\'" p)) paths))))))) - -(ert-deftest test-gptel-tools-list-list-directory-recursive () - "Recursive listing also returns sub-directory contents." - (test-gptel-tools-list--with-tree - (lambda (root) - (let* ((result (list-directory-files--list-directory root t nil)) - (files (plist-get result :files)) - (paths (mapcar (lambda (i) (plist-get i :path)) files))) - (should (cl-some (lambda (p) (string-match-p "/c\\.txt\\'" p)) paths)))))) - -(ert-deftest test-gptel-tools-list-list-directory-max-depth () - "Boundary: max-depth limits recursive traversal." - (test-gptel-tools-list--with-tree - (lambda (root) - (let* ((result (list-directory-files--list-directory root t nil 0)) - (files (plist-get result :files)) - (paths (mapcar (lambda (i) (plist-get i :path)) files))) - (should-not (cl-some (lambda (p) (string-match-p "/c\\.txt\\'" p)) paths)))))) - -(ert-deftest test-gptel-tools-list-list-directory-filtered-recursive-keeps-matching-files () - "Normal: recursive extension filter returns matching nested files." - (test-gptel-tools-list--with-tree - (lambda (root) - (let* ((filter (list-directory-files--filter-by-extension "txt")) - (result (list-directory-files--list-directory root t filter)) - (files (plist-get result :files)) - (paths (mapcar (lambda (i) (plist-get i :path)) files))) - (should (cl-some (lambda (p) (string-match-p "/a\\.txt\\'" p)) paths)) - (should (cl-some (lambda (p) (string-match-p "/c\\.txt\\'" p)) paths)) - (should-not (cl-some (lambda (p) (string-match-p "/b\\.org\\'" p)) paths)))))) - -(ert-deftest test-gptel-tools-list-list-directory-records-entry-errors () - "Error: per-entry metadata failures are collected." - (test-gptel-tools-list--with-tree - (lambda (root) - (cl-letf (((symbol-function 'list-directory-files--get-file-info) - (lambda (path) - (if (string-match-p "/a\\.txt\\'" path) - (list :success nil :path path :error "denied") - (let* ((attrs (file-attributes path 'string)) - (dirp (eq t (file-attribute-type attrs)))) - (list :success t - :path path - :size 0 - :last-modified (current-time) - :is-directory dirp - :permissions "-rw-r--r--" - :executable nil)))))) - (let ((errors (plist-get (list-directory-files--list-directory root nil nil) - :errors))) - (should errors) - (should (string-match-p "denied" (car errors)))))))) - -(ert-deftest test-gptel-tools-list-list-directory-error-not-a-directory () - "Non-directory path returns errors entry." - (test-gptel-tools-list--with-tree - (lambda (root) - (let* ((result (list-directory-files--list-directory - (expand-file-name "a.txt" root) nil nil)) - (errors (plist-get result :errors))) - (should errors))))) - -(ert-deftest test-gptel-tools-list-list-directory-error-accessing-directory () - "Error: directory access failures are collected." - (test-gptel-tools-list--with-tree - (lambda (root) - (cl-letf (((symbol-function 'directory-files) - (lambda (&rest _args) (error "cannot list")))) - (let ((errors (plist-get (list-directory-files--list-directory root nil nil) - :errors))) - (should errors) - (should (string-match-p "cannot list" (car errors)))))))) - -;; -------------------------- format-output - -(ert-deftest test-gptel-tools-list-format-output-has-files-section () - "Format-output includes a \"Found N file(s)\" line when files present." - (test-gptel-tools-list--with-tree - (lambda (root) - (let* ((result (list-directory-files--list-directory root nil nil)) - (out (list-directory-files--format-output root result))) - (should (string-match-p "Found [0-9]+ file" out)))))) - -(ert-deftest test-gptel-tools-list-format-output-empty () - "Empty result: \"No files found\"." - (let ((out (list-directory-files--format-output - "/nowhere" '(:files nil :errors nil)))) - (should (string-match-p "No files found" out)))) - -(ert-deftest test-gptel-tools-list-format-output-errors-only () - "Format-output includes errors when no files are present." - (let ((out (list-directory-files--format-output - "/nowhere" '(:files nil :errors ("boom"))))) - (should (string-match-p "Errors encountered" out)) - (should (string-match-p "boom" out)))) - -(ert-deftest test-gptel-tools-list-format-output-files-and-errors () - "Format-output separates file listings and errors." - (let* ((info (list :success t - :path (expand-file-name "foo.txt" "~") - :size 1 - :last-modified (current-time) - :is-directory nil - :permissions "-rw-r--r--" - :executable nil)) - (out (list-directory-files--format-output - "~" (list :files (list info) :errors (list "boom"))))) - (should (string-match-p "Found 1 file" out)) - (should (string-match-p "Errors encountered" out)))) - -(provide 'test-gptel-tools-list-directory-files) -;;; test-gptel-tools-list-directory-files.el ends here diff --git a/tests/test-gptel-tools-move-to-trash.el b/tests/test-gptel-tools-move-to-trash.el deleted file mode 100644 index 77f886277..000000000 --- a/tests/test-gptel-tools-move-to-trash.el +++ /dev/null @@ -1,219 +0,0 @@ -;;; test-gptel-tools-move-to-trash.el --- Tests for move_to_trash gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the helpers in move_to_trash.el. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'move_to_trash) - -;; -------------------------- helpers - -(defun test-gptel-tools-trash--with-tmp-tree (fn) - "Create a temp source dir and trash dir; run FN with both; clean up." - (let* ((src (make-temp-file "test-gptel-tools-trash-src-" t)) - (trash (make-temp-file "test-gptel-tools-trash-dst-" t))) - (unwind-protect - (funcall fn src trash) - (when (file-exists-p src) (delete-directory src t)) - (when (file-exists-p trash) (delete-directory trash t))))) - -;; -------------------------- generate-unique-name - -(ert-deftest test-gptel-tools-trash-generate-unique-name-no-conflict () - "No conflict: returns the plain base name in trash." - (test-gptel-tools-trash--with-tmp-tree - (lambda (_src trash) - (let ((out (gptel--move-to-trash-generate-unique-name - "/anywhere/foo.txt" trash))) - (should (equal (file-name-nondirectory out) "foo.txt")))))) - -(ert-deftest test-gptel-tools-trash-generate-unique-name-conflict-timestamps () - "Name conflict: returns a name with a timestamp suffix." - (test-gptel-tools-trash--with-tmp-tree - (lambda (_src trash) - (with-temp-file (expand-file-name "foo.txt" trash) (insert "")) - (let* ((out (gptel--move-to-trash-generate-unique-name - "/anywhere/foo.txt" trash)) - (name (file-name-nondirectory out))) - (should-not (equal name "foo.txt")) - (should (string-match-p "\\`foo-[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}-[0-9]\\{2\\}-[0-9]\\{2\\}-[0-9]\\{2\\}\\.txt\\'" - name)))))) - -(ert-deftest test-gptel-tools-trash-generate-unique-name-no-extension () - "Conflict on a name without extension: timestamp appended to the bare name." - (test-gptel-tools-trash--with-tmp-tree - (lambda (_src trash) - (with-temp-file (expand-file-name "noext" trash) (insert "")) - (let* ((out (gptel--move-to-trash-generate-unique-name - "/anywhere/noext" trash)) - (name (file-name-nondirectory out))) - (should-not (equal name "noext")) - (should (string-match-p "\\`noext-[0-9]" name)))))) - -;; -------------------------- validate-path - -(ert-deftest test-gptel-tools-trash-validate-path-normal-home () - "Normal: an existing path under HOME validates." - (let ((path (expand-file-name - (format ".test-gptel-tools-trash-home-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (with-temp-file path (insert "")) - (should (equal (gptel--move-to-trash-validate-path path) - (expand-file-name path)))) - (when (file-exists-p path) (delete-file path))))) - -(ert-deftest test-gptel-tools-trash-validate-path-normal-tmp () - "Normal: an existing path under /tmp validates." - (let ((path (make-temp-file "test-gptel-tools-trash-tmpvalidate-"))) - (unwind-protect - (should (equal (gptel--move-to-trash-validate-path path) - (expand-file-name path))) - (when (file-exists-p path) (delete-file path))))) - -(ert-deftest test-gptel-tools-trash-validate-path-error-outside-allowed () - "Error: a path outside HOME or /tmp signals." - (should-error (gptel--move-to-trash-validate-path "/etc/hostname"))) - -(ert-deftest test-gptel-tools-trash-validate-path-error-tmp-prefix-trick () - "Error: paths that merely start with /tmp are not treated as /tmp children." - (should-error (gptel--move-to-trash-validate-path "/tmpnotreally/file"))) - -(ert-deftest test-gptel-tools-trash-validate-path-error-critical-dir () - "Error: critical directories (home root, .emacs.d, .config, /tmp) signal." - (should-error (gptel--move-to-trash-validate-path "~")) - (should-error (gptel--move-to-trash-validate-path "~/.emacs.d")) - (should-error (gptel--move-to-trash-validate-path "~/.config")) - (should-error (gptel--move-to-trash-validate-path "/tmp"))) - -(ert-deftest test-gptel-tools-trash-validate-path-error-missing () - "Error: missing path signals." - (let ((path (expand-file-name - (format ".test-gptel-tools-trash-missing-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (when (file-exists-p path) (delete-file path)) - (should-error (gptel--move-to-trash-validate-path path)))) - -(ert-deftest test-gptel-tools-trash-validate-path-error-symlink-outside-allowed () - "Error: allowed-location symlinks resolving outside allowed roots are rejected." - (let ((link (expand-file-name - (format ".test-gptel-tools-trash-outside-link-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link "/etc/hostname" link t) - (should-error (gptel--move-to-trash-validate-path link))) - (when (file-symlink-p link) (delete-file link))))) - -;; -------------------------- perform - -(ert-deftest test-gptel-tools-trash-perform-moves-file () - "Perform: moves the file out of the source dir into the trash dir." - (test-gptel-tools-trash--with-tmp-tree - (lambda (src trash) - (let ((file (expand-file-name "doomed.txt" src))) - (with-temp-file file (insert "trash me")) - (let ((status (gptel--move-to-trash-perform file trash))) - (should (string-match-p "moved to trash" status)) - (should-not (file-exists-p file)) - (should (file-exists-p (expand-file-name "doomed.txt" trash)))))))) - -(ert-deftest test-gptel-tools-trash-perform-handles-directory () - "Perform: moves a directory as a unit." - (test-gptel-tools-trash--with-tmp-tree - (lambda (src trash) - (let ((dir (expand-file-name "subdir" src))) - (make-directory dir) - (with-temp-file (expand-file-name "inside.txt" dir) (insert "x")) - (let ((status (gptel--move-to-trash-perform dir trash))) - (should (string-match-p "Directory moved to trash" status)) - (should-not (file-exists-p dir)) - (should (file-exists-p (expand-file-name "subdir/inside.txt" trash)))))))) - -(ert-deftest test-gptel-tools-trash-perform-handles-symlink () - "Perform: moving a symlink moves the link, not its target." - (test-gptel-tools-trash--with-tmp-tree - (lambda (src trash) - (let ((target (expand-file-name "target.txt" src)) - (link (expand-file-name "link.txt" src))) - (with-temp-file target (insert "target")) - (make-symbolic-link target link t) - (let ((status (gptel--move-to-trash-perform link trash))) - (should (string-match-p "Symlink moved to trash" status)) - (should (file-exists-p target)) - (should-not (file-symlink-p link)) - (should (file-symlink-p (expand-file-name "link.txt" trash)))))))) - -(ert-deftest test-gptel-tools-trash-perform-error-rename-failure () - "Error: rename failures are reported with context." - (test-gptel-tools-trash--with-tmp-tree - (lambda (src trash) - (let ((file (expand-file-name "doomed.txt" src))) - (with-temp-file file (insert "trash me")) - (cl-letf (((symbol-function 'rename-file) - (lambda (&rest _args) (error "rename failed")))) - (should-error (gptel--move-to-trash-perform file trash))) - (should (file-exists-p file)))))) - -(ert-deftest test-gptel-tools-trash-perform-error-permission-denied () - "Error: permission-denied rename failures get a specific message." - (test-gptel-tools-trash--with-tmp-tree - (lambda (src trash) - (let ((file (expand-file-name "denied.txt" src))) - (with-temp-file file (insert "trash me")) - (cl-letf (((symbol-function 'rename-file) - (lambda (&rest _args) - (signal 'permission-denied '("denied"))))) - (should-error (gptel--move-to-trash-perform file trash) - :type 'error)) - (should (file-exists-p file)))))) - -(ert-deftest test-gptel-tools-trash-perform-error-original-still-exists () - "Error: post-move verification catches a source path that remains." - (test-gptel-tools-trash--with-tmp-tree - (lambda (src trash) - (let ((file (expand-file-name "still-there.txt" src))) - (with-temp-file file (insert "trash me")) - (cl-letf (((symbol-function 'rename-file) - (lambda (&rest _args) nil))) - (should-error (gptel--move-to-trash-perform file trash))) - (should (file-exists-p file)))))) - -(ert-deftest test-gptel-tools-trash-perform-error-trash-missing-after-move () - "Error: post-move verification catches a missing trash target." - (test-gptel-tools-trash--with-tmp-tree - (lambda (src trash) - (let ((file (expand-file-name "missing-trash.txt" src)) - (real-file-exists-p (symbol-function 'file-exists-p))) - (with-temp-file file (insert "trash me")) - (cl-letf (((symbol-function 'rename-file) - (lambda (&rest _args) nil)) - ((symbol-function 'file-exists-p) - (lambda (path) - (cond - ((equal path file) nil) - ((string-prefix-p trash path) nil) - (t (funcall real-file-exists-p path)))))) - (should-error (gptel--move-to-trash-perform file trash))) - (should (funcall real-file-exists-p file)))))) - -(provide 'test-gptel-tools-move-to-trash) -;;; test-gptel-tools-move-to-trash.el ends here diff --git a/tests/test-gptel-tools-read-buffer.el b/tests/test-gptel-tools-read-buffer.el deleted file mode 100644 index 0a8548359..000000000 --- a/tests/test-gptel-tools-read-buffer.el +++ /dev/null @@ -1,74 +0,0 @@ -;;; test-gptel-tools-read-buffer.el --- Tests for read_buffer gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for `cj/read-buffer--get-content', the testable helper that -;; backs the read_buffer gptel tool. - -;;; Code: - -(require 'ert) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'read_buffer) - -(ert-deftest test-gptel-tools-read-buffer-normal () - "Normal: returns the contents of an existing buffer." - (with-temp-buffer - (rename-buffer "test-gptel-tools-read-buffer-normal" t) - (insert "hello world") - (should (equal (cj/read-buffer--get-content (buffer-name)) "hello world")))) - -(ert-deftest test-gptel-tools-read-buffer-boundary-empty-buffer () - "Boundary: empty buffer returns the empty string." - (with-temp-buffer - (rename-buffer "test-gptel-tools-read-buffer-empty" t) - (should (equal (cj/read-buffer--get-content (buffer-name)) "")))) - -(ert-deftest test-gptel-tools-read-buffer-boundary-buffer-object () - "Boundary: accepts a buffer object as well as a name string." - (with-temp-buffer - (insert "from buffer object") - (should (equal (cj/read-buffer--get-content (current-buffer)) - "from buffer object")))) - -(ert-deftest test-gptel-tools-read-buffer-boundary-widened-content () - "Boundary: returns the whole buffer even when the buffer is narrowed." - (with-temp-buffer - (insert "visible\nhidden\n") - (narrow-to-region (point-min) (line-end-position)) - (should (equal (cj/read-buffer--get-content (current-buffer)) - "visible\nhidden\n")))) - -(ert-deftest test-gptel-tools-read-buffer-boundary-strips-text-properties () - "Boundary: the returned string has no text properties." - (with-temp-buffer - (rename-buffer "test-gptel-tools-read-buffer-props" t) - (insert (propertize "fontified" 'face 'bold)) - (let ((content (cj/read-buffer--get-content (buffer-name)))) - (should (equal content "fontified")) - (should-not (text-properties-at 0 content))))) - -(ert-deftest test-gptel-tools-read-buffer-error-missing-buffer () - "Error: nonexistent buffer name signals." - (when (get-buffer "test-gptel-tools-read-buffer-absent") - (kill-buffer "test-gptel-tools-read-buffer-absent")) - (should-error (cj/read-buffer--get-content - "test-gptel-tools-read-buffer-absent"))) - -(ert-deftest test-gptel-tools-read-buffer-error-killed-buffer-object () - "Error: a killed buffer object signals clearly." - (let ((buffer (generate-new-buffer "test-gptel-tools-read-buffer-killed"))) - (kill-buffer buffer) - (should-error (cj/read-buffer--get-content buffer)))) - -(provide 'test-gptel-tools-read-buffer) -;;; test-gptel-tools-read-buffer.el ends here diff --git a/tests/test-gptel-tools-read-text-file.el b/tests/test-gptel-tools-read-text-file.el deleted file mode 100644 index db3d6e7ed..000000000 --- a/tests/test-gptel-tools-read-text-file.el +++ /dev/null @@ -1,201 +0,0 @@ -;;; test-gptel-tools-read-text-file.el --- Tests for read_text_file gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the helpers in read_text_file.el. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'read_text_file) - -;; -------------------------- helpers - -(defun test-gptel-tools-read-text-file--in-home (suffix content fn) - "Run FN with a temp file (containing CONTENT) under HOME using SUFFIX." - (let* ((name (format ".test-gptel-tools-read-text-file-%s-%s.tmp" - suffix (format-time-string "%s%N"))) - (path (expand-file-name name "~"))) - (unwind-protect - (progn - (with-temp-file path (insert content)) - (funcall fn path)) - (when (file-exists-p path) (delete-file path))))) - -;; -------------------------- validate-file-path - -(ert-deftest test-gptel-tools-read-text-file-validate-path-normal () - "Normal: an existing readable file under HOME passes." - (test-gptel-tools-read-text-file--in-home - "normal" "hi" - (lambda (path) - (should (equal (cj/validate-file-path path) (file-truename path)))))) - -(ert-deftest test-gptel-tools-read-text-file-validate-path-error-outside-home () - "Error: path outside HOME signals." - (should-error (cj/validate-file-path "/etc/hostname"))) - -(ert-deftest test-gptel-tools-read-text-file-validate-path-error-missing () - "Error: missing file signals." - (let ((path (expand-file-name - (format ".test-gptel-tools-read-text-file-missing-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (when (file-exists-p path) (delete-file path)) - (should-error (cj/validate-file-path path)))) - -(ert-deftest test-gptel-tools-read-text-file-validate-path-error-directory () - "Error: a directory signals." - (should-error (cj/validate-file-path "~"))) - -(ert-deftest test-gptel-tools-read-text-file-validate-path-error-unreadable () - "Error: unreadable files signal." - (test-gptel-tools-read-text-file--in-home - "unreadable" "secret" - (lambda (path) - (cl-letf (((symbol-function 'file-readable-p) (lambda (_) nil))) - (should-error (cj/validate-file-path path)))))) - -(ert-deftest test-gptel-tools-read-text-file-validate-path-boundary-relative-home-path () - "Boundary: relative paths resolve under HOME." - (test-gptel-tools-read-text-file--in-home - "relative" "hi" - (lambda (path) - (let ((relative (file-relative-name path (expand-file-name "~")))) - (should (equal (cj/validate-file-path relative) - (file-truename path))))))) - -(ert-deftest test-gptel-tools-read-text-file-validate-path-boundary-symlink-inside-home () - "Boundary: symlinks inside HOME resolving inside HOME are accepted." - (test-gptel-tools-read-text-file--in-home - "symlink-target" "hi" - (lambda (target) - (let ((link (expand-file-name - (format ".test-gptel-tools-read-text-file-link-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link target link t) - (should (equal (cj/validate-file-path link) - (file-truename target)))) - (when (file-symlink-p link) (delete-file link))))))) - -(ert-deftest test-gptel-tools-read-text-file-validate-path-error-symlink-outside-home () - "Error: symlinks inside HOME pointing outside HOME are rejected." - (let ((outside (make-temp-file "test-gptel-tools-read-text-file-outside-")) - (link (expand-file-name - (format ".test-gptel-tools-read-text-file-outside-link-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link outside link t) - (should-error (cj/validate-file-path link))) - (when (file-exists-p outside) (delete-file outside)) - (when (file-symlink-p link) (delete-file link))))) - -;; -------------------------- get-file-metadata - -(ert-deftest test-gptel-tools-read-text-file-get-metadata-shape () - "Returns a plist with :size and :string keys." - (test-gptel-tools-read-text-file--in-home - "meta" "abc" - (lambda (path) - (let ((meta (cj/get-file-metadata path))) - (should (plist-get meta :size)) - (should (= 3 (plist-get meta :size))) - (should (stringp (plist-get meta :string))) - (should (string-match-p "modified" (plist-get meta :string))))))) - -;; -------------------------- check-file-size-limits - -(ert-deftest test-gptel-tools-read-text-file-size-limits-normal () - "Small size below warning limit is a no-op." - (should-not (cj/check-file-size-limits 1024 nil))) - -(ert-deftest test-gptel-tools-read-text-file-size-limits-error-hard-cap () - "Sizes above 100MB always signal." - (should-error (cj/check-file-size-limits (* 101 1024 1024) t)) - (should-error (cj/check-file-size-limits (* 101 1024 1024) nil))) - -(ert-deftest test-gptel-tools-read-text-file-size-limits-warning-with-no-confirm () - "Above 10MB but below 100MB with no-confirm passes through silently." - (should-not (cj/check-file-size-limits (* 11 1024 1024) t))) - -(ert-deftest test-gptel-tools-read-text-file-size-limits-warning-user-accepts () - "Above warning limit proceeds when the user accepts." - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t))) - (should-not (cj/check-file-size-limits (* 11 1024 1024) nil)))) - -(ert-deftest test-gptel-tools-read-text-file-size-limits-warning-user-declines () - "Above warning limit signals when the user declines." - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) nil))) - (should-error (cj/check-file-size-limits (* 11 1024 1024) nil)))) - -;; -------------------------- detect-binary-file - -(ert-deftest test-gptel-tools-read-text-file-detect-binary-text-file () - "Text file: detect-binary returns nil." - (test-gptel-tools-read-text-file--in-home - "text" "plain ascii content" - (lambda (path) - (should-not (cj/detect-binary-file path))))) - -(ert-deftest test-gptel-tools-read-text-file-detect-binary-with-null-byte () - "File with NUL in first 1024 bytes returns truthy." - (test-gptel-tools-read-text-file--in-home - "bin" (concat "head\0tail") - (lambda (path) - (should (cj/detect-binary-file path))))) - -;; -------------------------- handle-special-file-types - -(ert-deftest test-gptel-tools-read-text-file-handle-special-epub-error () - "EPUB special-type handler signals \"not yet implemented\"." - (should-error (cj/handle-special-file-types "/tmp/foo.epub" t))) - -(ert-deftest test-gptel-tools-read-text-file-handle-special-epub-cancel () - "EPUB special-type handler signals when user declines extraction." - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) nil))) - (should-error (cj/handle-special-file-types "/tmp/foo.epub" nil)))) - -(ert-deftest test-gptel-tools-read-text-file-handle-special-pdf-cancel () - "PDF special-type handler signals when user declines extraction." - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) nil))) - (should-error (cj/handle-special-file-types "/tmp/foo.pdf" nil)))) - -(ert-deftest test-gptel-tools-read-text-file-handle-special-pdf-empty-extraction () - "PDF special-type handler signals when extraction returns empty text." - (cl-letf (((symbol-function 'shell-command-to-string) (lambda (_cmd) ""))) - (should-error (cj/handle-special-file-types "/tmp/foo.pdf" t)))) - -(ert-deftest test-gptel-tools-read-text-file-handle-special-pdf-text () - "PDF special-type handler returns extracted text." - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) "pdf text\n"))) - (should (equal (cj/handle-special-file-types "/tmp/foo.pdf" t) - "pdf text\n")))) - -(ert-deftest test-gptel-tools-read-text-file-handle-special-binary-cancel () - "Generic binary handler signals when user declines." - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) nil))) - (should-error (cj/handle-special-file-types "/tmp/foo.bin" nil)))) - -(ert-deftest test-gptel-tools-read-text-file-handle-special-binary-returns-nil () - "Generic binary file with no-confirm returns nil to indicate normal read." - (should-not (cj/handle-special-file-types "/tmp/foo.bin" t))) - -(provide 'test-gptel-tools-read-text-file) -;;; test-gptel-tools-read-text-file.el ends here diff --git a/tests/test-gptel-tools-web-fetch.el b/tests/test-gptel-tools-web-fetch.el deleted file mode 100644 index b6dbefccb..000000000 --- a/tests/test-gptel-tools-web-fetch.el +++ /dev/null @@ -1,230 +0,0 @@ -;;; test-gptel-tools-web-fetch.el --- Tests for web_fetch gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Validators and helpers tested directly. The orchestrator's network -;; call is stubbed via `cl-letf' on `url-retrieve-synchronously' / the -;; module's `--retrieve' helper; HTML stripping runs against real -;; pandoc / w3m (both are installed in this dev environment, and -;; verifying they don't mangle inputs is the point). - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'web_fetch) - -;; ---------- validate-url - -(ert-deftest test-gptel-tools-web-fetch-validate-url-http () - "Normal: http URL passes." - (should (equal (cj/gptel-web-fetch--validate-url "http://example.com") - "http://example.com"))) - -(ert-deftest test-gptel-tools-web-fetch-validate-url-https () - "Normal: https URL passes." - (should (equal (cj/gptel-web-fetch--validate-url "https://example.com/path") - "https://example.com/path"))) - -(ert-deftest test-gptel-tools-web-fetch-validate-url-error-non-string () - "Error: non-string URL signals." - (should-error (cj/gptel-web-fetch--validate-url nil)) - (should-error (cj/gptel-web-fetch--validate-url 42))) - -(ert-deftest test-gptel-tools-web-fetch-validate-url-error-empty () - "Error: empty URL signals." - (should-error (cj/gptel-web-fetch--validate-url ""))) - -(ert-deftest test-gptel-tools-web-fetch-validate-url-error-non-http-scheme () - "Error: schemes other than http/https are rejected." - (should-error (cj/gptel-web-fetch--validate-url "file:///etc/hostname")) - (should-error (cj/gptel-web-fetch--validate-url "ftp://example.com")) - (should-error (cj/gptel-web-fetch--validate-url "javascript:alert(1)")) - (should-error (cj/gptel-web-fetch--validate-url "example.com"))) ; no scheme - -;; ---------- effective-max-bytes - -(ert-deftest test-gptel-tools-web-fetch-max-bytes-default-on-nil () - "Boundary: nil falls back to the default cap." - (should (= (cj/gptel-web-fetch--effective-max-bytes nil) - cj/gptel-web-fetch--default-max-bytes))) - -(ert-deftest test-gptel-tools-web-fetch-max-bytes-clamp-low () - "Boundary: zero / negative fall back to the default." - (should (= (cj/gptel-web-fetch--effective-max-bytes 0) - cj/gptel-web-fetch--default-max-bytes)) - (should (= (cj/gptel-web-fetch--effective-max-bytes -1) - cj/gptel-web-fetch--default-max-bytes))) - -(ert-deftest test-gptel-tools-web-fetch-max-bytes-cap-high () - "Boundary: values above the hard cap are clamped." - (should (= (cj/gptel-web-fetch--effective-max-bytes (* 10 1024 1024)) - cj/gptel-web-fetch--hard-max-bytes))) - -(ert-deftest test-gptel-tools-web-fetch-max-bytes-normal () - "Normal: a sensible value passes through." - (should (= (cj/gptel-web-fetch--effective-max-bytes 50000) 50000))) - -;; ---------- truncate - -(ert-deftest test-gptel-tools-web-fetch-truncate-under-cap () - "Normal: small input returns unchanged." - (should (equal (cj/gptel-web-fetch--truncate "short" 1000) "short"))) - -(ert-deftest test-gptel-tools-web-fetch-truncate-at-cap () - "Boundary: input exactly at cap returns unchanged." - (let ((s (make-string 10 ?x))) - (should (equal (cj/gptel-web-fetch--truncate s 10) s)))) - -(ert-deftest test-gptel-tools-web-fetch-truncate-over-cap () - "Boundary: oversize input is truncated and marked." - (let* ((s (make-string 1000 ?x)) - (out (cj/gptel-web-fetch--truncate s 100))) - (should (string-match-p "\\[truncated:" out)) - (should (string-match-p "1000 bytes total" out)))) - -;; ---------- html-to-text - -(ert-deftest test-gptel-tools-web-fetch-html-to-text-strips-tags () - "Normal: pandoc / w3m strip HTML tags from real markup." - (let ((out (cj/gptel-web-fetch--html-to-text - "<html><body><h1>Hello</h1><p>World</p></body></html>"))) - (should (string-match-p "Hello" out)) - (should (string-match-p "World" out)) - (should-not (string-match-p "<h1>" out)) - (should-not (string-match-p "<p>" out)))) - -(ert-deftest test-gptel-tools-web-fetch-html-to-text-error-when-neither-on-path () - "Error: when neither pandoc nor w3m is on PATH, signals user-error." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) - (should-error (cj/gptel-web-fetch--html-to-text "<p>x</p>")))) - -(ert-deftest test-gptel-tools-web-fetch-html-to-text-error-on-tool-failure () - "Error: a failing HTML stripping command is reported." - (cl-letf (((symbol-function 'executable-find) - (lambda (program) (and (equal program "pandoc") "/bin/pandoc"))) - ((symbol-function 'call-process-region) - (lambda (&rest _args) 9))) - (should-error (cj/gptel-web-fetch--html-to-text "<p>x</p>")))) - -(ert-deftest test-gptel-tools-web-fetch-html-to-text-falls-back-to-w3m () - "Boundary: w3m is used when pandoc is unavailable." - (let (called-program) - (cl-letf (((symbol-function 'executable-find) - (lambda (program) (and (equal program "w3m") "/bin/w3m"))) - ((symbol-function 'call-process-region) - (lambda (start end program delete output display &rest _args) - (setq called-program program) - (should delete) - (should output) - (should-not display) - (delete-region start end) - (insert "w3m text") - 0))) - (should (equal (cj/gptel-web-fetch--html-to-text "<p>x</p>") - "w3m text")) - (should (equal called-program "w3m"))))) - -;; ---------- retrieve - -(ert-deftest test-gptel-tools-web-fetch-retrieve-normal-crlf-headers () - "Normal: retrieval parses status and body after CRLF headers." - (let ((buffer (generate-new-buffer " *web-fetch-crlf*"))) - (with-current-buffer buffer - (insert "HTTP/1.1 201 Created\r\nContent-Type: text/plain\r\n\r\nhello")) - (cl-letf (((symbol-function 'url-retrieve-synchronously) - (lambda (&rest _args) buffer))) - (should (equal (cj/gptel-web-fetch--retrieve "https://example.com") - '(201 . "hello")))) - (should-not (buffer-live-p buffer)))) - -(ert-deftest test-gptel-tools-web-fetch-retrieve-boundary-lf-headers () - "Boundary: retrieval also handles LF-only headers." - (let ((buffer (generate-new-buffer " *web-fetch-lf*"))) - (with-current-buffer buffer - (insert "HTTP/1.1 200 OK\nContent-Type: text/plain\n\nhello")) - (cl-letf (((symbol-function 'url-retrieve-synchronously) - (lambda (&rest _args) buffer))) - (should (equal (cj/gptel-web-fetch--retrieve "https://example.com") - '(200 . "hello")))))) - -(ert-deftest test-gptel-tools-web-fetch-retrieve-boundary-no-header-separator () - "Boundary: unseparated responses return the full buffer as body." - (let ((buffer (generate-new-buffer " *web-fetch-no-separator*"))) - (with-current-buffer buffer - (insert "not an http response")) - (cl-letf (((symbol-function 'url-retrieve-synchronously) - (lambda (&rest _args) buffer))) - (should (equal (cj/gptel-web-fetch--retrieve "https://example.com") - '(nil . "not an http response")))))) - -(ert-deftest test-gptel-tools-web-fetch-retrieve-error-no-response () - "Error: nil retrieval buffer signals network failure." - (cl-letf (((symbol-function 'url-retrieve-synchronously) - (lambda (&rest _args) nil))) - (should-error (cj/gptel-web-fetch--retrieve "https://example.com")))) - -;; ---------- run (orchestrator) - -(ert-deftest test-gptel-tools-web-fetch-run-normal-strips-html () - "Normal: orchestrator returns stripped text by default." - (cl-letf (((symbol-function 'cj/gptel-web-fetch--retrieve) - (lambda (_url) - (cons 200 "<html><body><p>fetched</p></body></html>")))) - (let ((out (cj/gptel-web-fetch--run "https://example.com"))) - (should (string-match-p "fetched" out)) - (should-not (string-match-p "<p>" out))))) - -(ert-deftest test-gptel-tools-web-fetch-run-raw-returns-body-verbatim () - "Normal: raw=t returns the response body without HTML stripping." - (cl-letf (((symbol-function 'cj/gptel-web-fetch--retrieve) - (lambda (_url) - (cons 200 "<html><body><p>raw</p></body></html>")))) - (let ((out (cj/gptel-web-fetch--run "https://example.com" t))) - (should (string-match-p "<p>raw</p>" out))))) - -(ert-deftest test-gptel-tools-web-fetch-run-error-on-4xx () - "Error: HTTP 4xx response signals." - (cl-letf (((symbol-function 'cj/gptel-web-fetch--retrieve) - (lambda (_url) (cons 404 "not found")))) - (should-error (cj/gptel-web-fetch--run "https://example.com")))) - -(ert-deftest test-gptel-tools-web-fetch-run-error-on-5xx () - "Error: HTTP 5xx response signals." - (cl-letf (((symbol-function 'cj/gptel-web-fetch--retrieve) - (lambda (_url) (cons 503 "service unavailable")))) - (should-error (cj/gptel-web-fetch--run "https://example.com")))) - -(ert-deftest test-gptel-tools-web-fetch-run-boundary-nil-status () - "Boundary: an unparseable status line does not trigger HTTP error handling." - (cl-letf (((symbol-function 'cj/gptel-web-fetch--retrieve) - (lambda (_url) (cons nil "raw body")))) - (should (equal (cj/gptel-web-fetch--run "https://example.com" t) - "raw body")))) - -(ert-deftest test-gptel-tools-web-fetch-run-truncates-oversized-body () - "Boundary: an oversize body is truncated by the run wrapper." - (let ((big (concat "<html><body>" - (make-string 1000 ?x) - "</body></html>"))) - (cl-letf (((symbol-function 'cj/gptel-web-fetch--retrieve) - (lambda (_url) (cons 200 big)))) - (let ((out (cj/gptel-web-fetch--run "https://example.com" t 200))) - (should (string-match-p "\\[truncated:" out)))))) - -(ert-deftest test-gptel-tools-web-fetch-run-error-on-bad-scheme () - "Error: non-http URL fails fast at the validator." - (should-error (cj/gptel-web-fetch--run "file:///etc/passwd"))) - -(provide 'test-gptel-tools-web-fetch) -;;; test-gptel-tools-web-fetch.el ends here diff --git a/tests/test-gptel-tools-write-text-file.el b/tests/test-gptel-tools-write-text-file.el deleted file mode 100644 index 14bcb2a51..000000000 --- a/tests/test-gptel-tools-write-text-file.el +++ /dev/null @@ -1,223 +0,0 @@ -;;; test-gptel-tools-write-text-file.el --- Tests for write_text_file gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for `cj/write-text-file--run' and its helpers. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'write_text_file) - -;; ------------------------------------------------------- helpers - -(defun test-gptel-tools-write-text-file--in-home (suffix fn) - "Run FN with a fresh path under HOME using SUFFIX. Clean up after." - (let* ((name (format ".test-gptel-tools-write-text-file-%s-%s.tmp" - suffix (format-time-string "%s%N"))) - (path (expand-file-name name "~"))) - (unwind-protect - (funcall fn path) - (when (file-exists-p path) (delete-file path)) - (dolist (b (file-expand-wildcards (concat path "-*.bak"))) - (when (file-exists-p b) (delete-file b)))))) - -;; --------------------------------------------- validate-path - -(ert-deftest test-gptel-tools-write-text-file-validate-path-normal () - "Normal: returns the expanded path for a HOME-relative input." - (let ((result (cj/write-text-file--validate-path "foo.txt"))) - (should (string-prefix-p (expand-file-name "~") result)) - (should (string-suffix-p "/foo.txt" result)))) - -(ert-deftest test-gptel-tools-write-text-file-validate-path-error-outside-home () - "Error: a path outside HOME signals." - (should-error (cj/write-text-file--validate-path "/etc/hostname"))) - -(ert-deftest test-gptel-tools-write-text-file-validate-path-boundary-absolute-home-path () - "Boundary: absolute HOME paths are accepted." - (test-gptel-tools-write-text-file--in-home - "absolute" - (lambda (path) - (should (equal (cj/write-text-file--validate-path path) path))))) - -(ert-deftest test-gptel-tools-write-text-file-validate-path-error-existing-symlink-outside-home () - "Error: an existing symlink inside HOME pointing outside HOME is rejected." - (let ((outside (make-temp-file "test-gptel-tools-write-text-file-outside-")) - (link (expand-file-name - (format ".test-gptel-tools-write-text-file-outside-link-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link outside link t) - (should-error (cj/write-text-file--validate-path link))) - (when (file-exists-p outside) (delete-file outside)) - (when (file-symlink-p link) (delete-file link))))) - -(ert-deftest test-gptel-tools-write-text-file-validate-path-error-parent-symlink-outside-home () - "Error: a parent symlink inside HOME pointing outside HOME is rejected." - (let ((outside-dir (make-temp-file "test-gptel-tools-write-text-file-outside-dir-" t)) - (link-dir (expand-file-name - (format ".test-gptel-tools-write-text-file-outside-dir-link-%s" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link outside-dir link-dir t) - (should-error - (cj/write-text-file--validate-path - (expand-file-name "child.txt" link-dir)))) - (when (file-symlink-p link-dir) (delete-file link-dir)) - (when (file-exists-p outside-dir) (delete-directory outside-dir t))))) - -;; --------------------------------------------- backup-name - -(ert-deftest test-gptel-tools-write-text-file-backup-name-shape () - "Backup names append a YYYY-MM-DD-HHMMSS suffix and .bak." - (let ((name (cj/write-text-file--backup-name "/home/user/foo.txt"))) - (should (string-prefix-p "/home/user/foo.txt-" name)) - (should (string-suffix-p ".bak" name)) - (should (string-match-p "-[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}-[0-9]\\{6\\}\\.bak\\'" - name)))) - -;; --------------------------------------------- ensure-parent - -(ert-deftest test-gptel-tools-write-text-file-ensure-parent-creates-missing () - "Normal: creates missing parent directories." - (let* ((base (make-temp-file "test-gptel-tools-write-text-file-" t)) - (deep (expand-file-name "a/b/c/file.txt" base))) - (unwind-protect - (progn - (cj/write-text-file--ensure-parent deep) - (should (file-directory-p (file-name-directory deep)))) - (delete-directory base t)))) - -(ert-deftest test-gptel-tools-write-text-file-ensure-parent-error-unwritable () - "Error: an unwritable parent signals." - (let* ((parent (make-temp-file "test-gptel-tools-write-text-file-ro-" t)) - (target (expand-file-name "child.txt" parent))) - (unwind-protect - (progn - (set-file-modes parent #o500) - (should-error (cj/write-text-file--ensure-parent target))) - (set-file-modes parent #o700) - (delete-directory parent t)))) - -(ert-deftest test-gptel-tools-write-text-file-ensure-parent-error-create-fails () - "Error: directory creation failures are wrapped with context." - (cl-letf (((symbol-function 'make-directory) - (lambda (&rest _args) (error "boom")))) - (should-error - (cj/write-text-file--ensure-parent - (expand-file-name "missing/child.txt" temporary-file-directory))))) - -;; --------------------------------------------- run - -(ert-deftest test-gptel-tools-write-text-file-run-normal () - "Normal: writes new content and returns a status string." - (test-gptel-tools-write-text-file--in-home - "new" - (lambda (path) - (let ((result (cj/write-text-file--run - (file-name-nondirectory path) "hello\n" nil))) - (should (string-match-p "Successfully wrote" result)) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "hello\n"))))))) - -(ert-deftest test-gptel-tools-write-text-file-run-error-existing-no-overwrite () - "Error: existing file without overwrite signals." - (test-gptel-tools-write-text-file--in-home - "existing" - (lambda (path) - (with-temp-file path (insert "old content\n")) - (should-error (cj/write-text-file--run - (file-name-nondirectory path) "new content\n" nil)) - ;; File preserved - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "old content\n")))))) - -(ert-deftest test-gptel-tools-write-text-file-run-overwrite-creates-backup () - "Overwrite path makes a timestamped backup before writing." - (test-gptel-tools-write-text-file--in-home - "overwrite" - (lambda (path) - (with-temp-file path (insert "old content\n")) - (cj/write-text-file--run - (file-name-nondirectory path) "new content\n" t) - ;; New content landed - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "new content\n"))) - ;; Backup exists with old content - (let ((backups (file-expand-wildcards (concat path "-*.bak")))) - (should (= 1 (length backups))) - (with-temp-buffer - (insert-file-contents (car backups)) - (should (equal (buffer-string) "old content\n"))))))) - -(ert-deftest test-gptel-tools-write-text-file-run-boundary-empty-content () - "Boundary: nil content writes an empty file." - (test-gptel-tools-write-text-file--in-home - "empty" - (lambda (path) - (cj/write-text-file--run (file-name-nondirectory path) nil nil) - (should (file-exists-p path)) - (should (= 0 (file-attribute-size (file-attributes path))))))) - -(ert-deftest test-gptel-tools-write-text-file-run-large-user-accepts () - "Boundary: large writes proceed when the user accepts." - (test-gptel-tools-write-text-file--in-home - "large-accept" - (lambda (path) - (let ((cj/write-text-file--size-limit 3)) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t))) - (cj/write-text-file--run (file-name-nondirectory path) "abcdef" nil))) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "abcdef")))))) - -(ert-deftest test-gptel-tools-write-text-file-run-large-user-declines () - "Error: large writes cancel cleanly when the user declines." - (test-gptel-tools-write-text-file--in-home - "large-decline" - (lambda (path) - (let ((cj/write-text-file--size-limit 3)) - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) nil))) - (should-error - (cj/write-text-file--run (file-name-nondirectory path) "abcdef" nil)))) - (should-not (file-exists-p path))))) - -(ert-deftest test-gptel-tools-write-text-file-run-error-overwrite-backup-failure-preserves-file () - "Error: backup failure prevents overwrite and preserves existing file." - (test-gptel-tools-write-text-file--in-home - "backup-fails" - (lambda (path) - (with-temp-file path (insert "old\n")) - (cl-letf (((symbol-function 'copy-file) - (lambda (&rest _args) (error "copy failed")))) - (should-error - (cj/write-text-file--run (file-name-nondirectory path) "new\n" t))) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "old\n")))))) - -(ert-deftest test-gptel-tools-write-text-file-run-error-outside-home () - "Error: a path outside HOME signals." - (should-error (cj/write-text-file--run "/etc/test-write.txt" "x" nil))) - -(provide 'test-gptel-tools-write-text-file) -;;; test-gptel-tools-write-text-file.el ends here diff --git a/tests/test-help-config.el b/tests/test-help-config.el new file mode 100644 index 000000000..0ba95c410 --- /dev/null +++ b/tests/test-help-config.el @@ -0,0 +1,32 @@ +;;; test-help-config.el --- Tests for the Info-open decision logic -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/open-with-info-mode opens the current .info buffer in Info, prompting to +;; save first if the buffer is modified. The save/cancel/open decision is +;; factored into the pure helper `cj/--info-open-plan' so it's testable without +;; driving find-file, Info, or the save prompt. Declining the prompt must yield +;; `cancel' -- the original cl-return-from inside a plain defun signalled +;; "No catch for tag" instead of cancelling. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'help-config) + +(ert-deftest test-info-open-plan-unmodified-opens () + "Normal: an unmodified buffer opens in Info directly." + (should (eq (cj/--info-open-plan nil nil) 'open))) + +(ert-deftest test-info-open-plan-modified-confirmed-saves-then-opens () + "Normal: a modified buffer whose save is confirmed saves, then opens." + (should (eq (cj/--info-open-plan t t) 'save-then-open))) + +(ert-deftest test-info-open-plan-modified-declined-cancels () + "Error/edge: a modified buffer whose save is declined cancels -- the path that +used to signal \"No catch for tag\" via cl-return-from in a plain defun." + (should (eq (cj/--info-open-plan t nil) 'cancel))) + +(provide 'test-help-config) +;;; test-help-config.el ends here diff --git a/tests/test-host-environment--detect-system-timezone.el b/tests/test-host-environment--detect-system-timezone.el index c24ac183a..209283d1e 100644 --- a/tests/test-host-environment--detect-system-timezone.el +++ b/tests/test-host-environment--detect-system-timezone.el @@ -22,7 +22,7 @@ (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () "America/Los_Angeles")) ((symbol-function 'getenv) - (lambda (_) (error "TZ should not have been consulted")))) + (lambda (_ &rest _) (error "TZ should not have been consulted")))) (should (equal (cj/detect-system-timezone) "America/Los_Angeles")))) (ert-deftest test-host-environment-detect-tz-env-var-wins-when-match-nil () @@ -30,7 +30,7 @@ (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (name) (when (string= name "TZ") "Europe/Berlin")))) + (lambda (name &rest _) (when (string= name "TZ") "Europe/Berlin")))) (should (equal (cj/detect-system-timezone) "Europe/Berlin")))) (ert-deftest test-host-environment-detect-tz-falls-through-to-etc-timezone () @@ -41,7 +41,7 @@ contents primitives." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (_) nil)) + (lambda (_ &rest _) nil)) ((symbol-function 'file-exists-p) (lambda (path) (string= path "/etc/timezone"))) ((symbol-function 'insert-file-contents) @@ -55,7 +55,7 @@ contents primitives." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (_) nil)) + (lambda (_ &rest _) nil)) ((symbol-function 'file-exists-p) (lambda (path) (string= path "/etc/timezone"))) ((symbol-function 'insert-file-contents) @@ -69,10 +69,35 @@ contents primitives." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) (lambda () nil)) ((symbol-function 'getenv) - (lambda (_) nil)) + (lambda (_ &rest _) nil)) ((symbol-function 'file-exists-p) (lambda (_) nil)) ((symbol-function 'file-symlink-p) (lambda (_) nil))) (should-not (cj/detect-system-timezone)))) +(ert-deftest test-host-environment-detect-tz-symlink-target-extracts-zone () + "Boundary: with methods 1-3 nil, a /etc/localtime symlink into zoneinfo +yields the zone after the /zoneinfo/ segment." + (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) + (lambda () nil)) + ((symbol-function 'getenv) (lambda (_ &rest _) nil)) + ((symbol-function 'file-exists-p) (lambda (_) nil)) + ((symbol-function 'file-symlink-p) + (lambda (path) (string= path "/etc/localtime"))) + ((symbol-function 'file-truename) + (lambda (_ &rest _) "/usr/share/zoneinfo/America/Denver"))) + (should (equal (cj/detect-system-timezone) "America/Denver")))) + +(ert-deftest test-host-environment-detect-tz-symlink-without-zoneinfo-is-nil () + "Error: a symlink target with no /zoneinfo/ segment yields nil." + (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) + (lambda () nil)) + ((symbol-function 'getenv) (lambda (_ &rest _) nil)) + ((symbol-function 'file-exists-p) (lambda (_) nil)) + ((symbol-function 'file-symlink-p) + (lambda (path) (string= path "/etc/localtime"))) + ((symbol-function 'file-truename) + (lambda (_ &rest _) "/var/lib/elsewhere/localtime"))) + (should-not (cj/detect-system-timezone)))) + (provide 'test-host-environment--detect-system-timezone) ;;; test-host-environment--detect-system-timezone.el ends here diff --git a/tests/test-host-environment--display-predicates.el b/tests/test-host-environment--display-predicates.el index 15dff2ef8..5a87b5009 100644 --- a/tests/test-host-environment--display-predicates.el +++ b/tests/test-host-environment--display-predicates.el @@ -26,7 +26,7 @@ GRAPHIC-P becomes the return of `(display-graphic-p)'." `(cl-letf (((symbol-function 'window-system) (lambda (&optional _) ,window-system-value)) ((symbol-function 'getenv) - (lambda (name) + (lambda (name &rest _) (when (string= name "WAYLAND_DISPLAY") ,wayland-display))) ((symbol-function 'display-graphic-p) (lambda (&optional _) ,graphic-p))) diff --git a/tests/test-hugo-config-commands.el b/tests/test-hugo-config-commands.el index 01df5fc18..07bc27ca3 100644 --- a/tests/test-hugo-config-commands.el +++ b/tests/test-hugo-config-commands.el @@ -134,7 +134,7 @@ stubbed before the org-mode-derived guard runs." ((symbol-function 'completing-read) (lambda (&rest _) "Foo Post")) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (cj/hugo-open-draft)) (should (equal opened "/tmp/foo.org")))) @@ -196,7 +196,7 @@ stubbed before the org-mode-derived guard runs." (msg nil)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) ((symbol-function 'kill-process) - (lambda (p) (setq killed p))) + (lambda (p &rest _) (setq killed p))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) @@ -210,7 +210,7 @@ stubbed before the org-mode-derived guard runs." (let ((cj/hugo--preview-process nil) (start-args nil)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'executable-find) (lambda (_) "/usr/bin/hugo")) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/hugo")) ((symbol-function 'start-process) (lambda (&rest args) (setq start-args args) @@ -226,7 +226,7 @@ stubbed before the org-mode-derived guard runs." "Error: a missing hugo binary signals user-error before start-process." (let ((cj/hugo--preview-process nil)) (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'executable-find) (lambda (_) nil)) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil)) ((symbol-function 'start-process) (lambda (&rest _) (error "start-process should not run"))) ((symbol-function 'message) #'ignore)) diff --git a/tests/test-hugo-config-open-blog-dir-external.el b/tests/test-hugo-config-open-blog-dir-external.el index 0bf689826..05f116e6d 100644 --- a/tests/test-hugo-config-open-blog-dir-external.el +++ b/tests/test-hugo-config-open-blog-dir-external.el @@ -44,7 +44,7 @@ filesystem checks." (cl-letf (((symbol-function 'env-macos-p) (lambda () ,macos-p)) ((symbol-function 'env-windows-p) (lambda () ,windows-p)) ((symbol-function 'file-directory-p) (lambda (_d) t)) - ((symbol-function 'executable-find) (lambda (cmd) cmd)) + ((symbol-function 'executable-find) (lambda (cmd &rest _) cmd)) ((symbol-function 'start-process) (lambda (_name _buf cmd &rest _args) (setq test-hugo--captured-process-cmd cmd)))) @@ -86,7 +86,7 @@ filesystem checks." ((symbol-function 'file-directory-p) (lambda (_d) nil)) ((symbol-function 'make-directory) (lambda (_dir &rest _args) (setq mkdir-called t))) - ((symbol-function 'executable-find) (lambda (cmd) cmd)) + ((symbol-function 'executable-find) (lambda (cmd &rest _) cmd)) ((symbol-function 'start-process) #'ignore)) (cj/hugo-open-blog-dir-external) (should mkdir-called)))) @@ -99,7 +99,7 @@ filesystem checks." ((symbol-function 'file-directory-p) (lambda (_d) t)) ((symbol-function 'make-directory) (lambda (_dir &rest _args) (setq mkdir-called t))) - ((symbol-function 'executable-find) (lambda (cmd) cmd)) + ((symbol-function 'executable-find) (lambda (cmd &rest _) cmd)) ((symbol-function 'start-process) #'ignore)) (cj/hugo-open-blog-dir-external) (should-not mkdir-called)))) @@ -111,7 +111,7 @@ filesystem checks." (cl-letf (((symbol-function 'env-macos-p) (lambda () nil)) ((symbol-function 'env-windows-p) (lambda () nil)) ((symbol-function 'file-directory-p) (lambda (_d) t)) - ((symbol-function 'executable-find) (lambda (_) nil)) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil)) ((symbol-function 'start-process) (lambda (&rest _) (error "start-process should not run")))) (should-error (cj/hugo-open-blog-dir-external) :type 'user-error))) diff --git a/tests/test-init-defer-games.el b/tests/test-init-defer-games.el new file mode 100644 index 000000000..f3ec94de8 --- /dev/null +++ b/tests/test-init-defer-games.el @@ -0,0 +1,46 @@ +;;; test-init-defer-games.el --- games-config Phase 4 deferral -*- lexical-binding: t; -*- + +;;; Commentary: +;; games-config is deferred (load-graph Phase 4): malyon and 2048-game autoload +;; their own commands via package.el, and init.el loads games-config (which only +;; supplies malyon's config) via `with-eval-after-load 'malyon'. These tests +;; guard the command availability and exercise the real autoload-invocation path +;; that M-x uses, which is where an earlier cut regressed ("Autoloading +;; games-config.el failed to define function malyon"). + +;;; Code: + +(require 'ert) +(require 'package) + +(ert-deftest test-init-defer-games-commands-autoload-without-module () + "Normal: the game commands resolve with games-config unloaded. +Dropping the eager require keeps malyon and 2048-game reachable only because the +packages autoload their own commands, so assert that holds." + (package-initialize) + (should-not (featurep 'games-config)) + (should (commandp 'malyon)) + (should (commandp '2048-game))) + +(ert-deftest test-init-defer-games-malyon-loads-and-configures () + "Normal: resolving malyon's autoload yields a real command and applies config. +Reproduces the M-x malyon path via `autoload-do-load': malyon autoloads from its +own package, init.el's `with-eval-after-load 'malyon' loads games-config, and +games-config sets the stories directory. This is the regression guard for the +earlier cut that autoloaded malyon to games-config, where Emacs errored that the +load failed to define malyon." + (package-initialize) + (add-to-list 'load-path (expand-file-name "modules" default-directory)) + (require 'user-constants) + (unless (and (fboundp 'malyon) (autoloadp (symbol-function 'malyon))) + (ert-skip "malyon package not available as an autoload")) + (let ((org-dir "/tmp/games-defer-test/")) + (with-eval-after-load 'malyon (require 'games-config)) ; the init.el wiring + (should-not (featurep 'games-config)) + (should (functionp (autoload-do-load (symbol-function 'malyon) 'malyon))) + (should (commandp 'malyon)) + (should (featurep 'games-config)) + (should (equal malyon-stories-directory "/tmp/games-defer-test/text.games/")))) + +(provide 'test-init-defer-games) +;;; test-init-defer-games.el ends here diff --git a/tests/test-init-module-headers.el b/tests/test-init-module-headers.el index bbda23887..22dec1d5f 100644 --- a/tests/test-init-module-headers.el +++ b/tests/test-init-module-headers.el @@ -2,7 +2,7 @@ ;;; Commentary: ;; Enforces the module load-graph header standard from -;; docs/design/init-load-graph.org against every module that has been +;; docs/specs/init-load-graph-spec-doing.org against every module that has been ;; classified so far. Classification proceeds in batches; a module joins ;; `test-init-header--classified-modules' once its header declares the ;; contract. When that list reaches parity with the modules required by @@ -94,7 +94,6 @@ "org-webclipper" "hugo-config" ;; Batch 8 — Domain / integration / optional modules (Layer 2-4) - "ai-config" "ai-term" "browser-config" "calendar-sync" @@ -106,6 +105,7 @@ "erc-config" "eshell-config" "eww-config" + "face-diagnostic" "flyspell-and-abbrev" "games-config" "gloss-config" @@ -129,7 +129,6 @@ "tramp-config" "transcription-config" "video-audio-recording" - "term-config" "weather-config" "wrap-up") "Modules annotated with the load-graph header contract. diff --git a/tests/test-jumper--location-candidates.el b/tests/test-jumper--location-candidates.el new file mode 100644 index 000000000..df095830a --- /dev/null +++ b/tests/test-jumper--location-candidates.el @@ -0,0 +1,52 @@ +;;; test-jumper--location-candidates.el --- Tests for jumper--location-candidates -*- lexical-binding: t; -*- + +;;; Commentary: +;; jumper--location-candidates is the (display . index) builder extracted from +;; the verbatim cl-loop in jumper-jump-to-location and jumper-remove-location. +;; It composes jumper--format-location (which now goes through the extracted +;; jumper--with-marker-at). The wrappers cover it transitively; this exercises +;; it directly against stored locations. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'jumper) + +(ert-deftest test-jumper-location-candidates-one-pair-per-stored-location () + "Normal: one (display . index) pair per stored location, indices in order." + (let ((saved-regs jumper--registers) + (saved-idx jumper--next-index)) + (unwind-protect + (progn + (setq jumper--registers (make-vector jumper-max-locations nil) + jumper--next-index 0) + (with-temp-buffer + (insert "line one\nline two\nline three\n") + (goto-char (point-min)) + (should (integerp (jumper--do-store-location))) ; index 0 + (forward-line 2) + (should (integerp (jumper--do-store-location))) ; index 1 + (let ((cands (jumper--location-candidates))) + (should (= (length cands) 2)) + (should (equal (mapcar #'cdr cands) '(0 1))) + (should (stringp (car (nth 0 cands)))) + (should (stringp (car (nth 1 cands))))))) + (setq jumper--registers saved-regs + jumper--next-index saved-idx)))) + +(ert-deftest test-jumper-location-candidates-empty-when-none-stored () + "Boundary: no stored locations yields an empty candidate list." + (let ((saved-regs jumper--registers) + (saved-idx jumper--next-index)) + (unwind-protect + (progn + (setq jumper--registers (make-vector jumper-max-locations nil) + jumper--next-index 0) + (should (null (jumper--location-candidates)))) + (setq jumper--registers saved-regs + jumper--next-index saved-idx)))) + +(provide 'test-jumper--location-candidates) +;;; test-jumper--location-candidates.el ends here diff --git a/tests/test-jumper--register-hygiene.el b/tests/test-jumper--register-hygiene.el new file mode 100644 index 000000000..8fc430ac5 --- /dev/null +++ b/tests/test-jumper--register-hygiene.el @@ -0,0 +1,179 @@ +;;; test-jumper--register-hygiene.el --- Tests for jumper register hygiene -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for three related jumper.el defects from the 2026-06 config audit: +;; +;; 1. Register collisions on removal — removal shifted the vector but never +;; freed the dropped register char, and a later store allocated by +;; `jumper--next-index' (a char a surviving slot might still hold), +;; silently overwriting that slot's marker. Store now allocates the first +;; free char in the live slice; removal clears the freed register. +;; 2. Dead-marker errors — `jumper--with-marker-at' guarded `markerp' but not +;; buffer liveness, so after the buffer holding a location was killed, +;; store/jump signaled wrong-type errors. Dead entries are now skipped. +;; 3. Single-location toggle never toggled back — the `already-there' branch +;; did nothing; it now jumps to the last-location register when set. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'jumper) + +(defvar test-jumper-hyg--orig-registers nil) +(defvar test-jumper-hyg--orig-index nil) + +(defun test-jumper-hyg-setup () + "Reset jumper state and the registers it uses to a clean slate." + (setq test-jumper-hyg--orig-registers jumper--registers) + (setq test-jumper-hyg--orig-index jumper--next-index) + (setq jumper--registers (make-vector jumper-max-locations nil)) + (setq jumper--next-index 0) + (dotimes (i jumper-max-locations) + (set-register (+ ?0 i) nil)) + (set-register jumper--last-location-register nil)) + +(defun test-jumper-hyg-teardown () + "Restore jumper state." + (setq jumper--registers test-jumper-hyg--orig-registers) + (setq jumper--next-index test-jumper-hyg--orig-index)) + +;;; Defect 1 — register collisions on removal + +(ert-deftest test-jumper-hyg-store-after-remove-reuses-freed-register () + "Normal: storing after a removal reuses the freed char, not next-index. +Removing index 0 of [0 1 2] leaves the live slice holding chars 1 and 2; +the next store must take the freed char 0, never 2 (which slot 1 still holds)." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2\nline 3\nline 4") + (goto-char (point-min)) + (jumper--do-store-location) ; ?0 @ line 1 + (forward-line 1) (jumper--do-store-location) ; ?1 @ line 2 + (forward-line 1) (jumper--do-store-location) ; ?2 @ line 3 + (jumper--do-remove-location 0) ; live slice now [?1 ?2] + (forward-line 1) ; line 4 + (let ((reg (jumper--do-store-location))) + (should (= reg ?0)) ; freed char reused + (should (= (aref jumper--registers 2) ?0)) + (should (= jumper--next-index 3)))) + (test-jumper-hyg-teardown))) + +(ert-deftest test-jumper-hyg-store-after-remove-preserves-survivor () + "Normal: the surviving slot's marker is not clobbered by the reused store. +After removing index 0 and storing a new location, jumping to the slot that +holds the old top register must still land on its original line." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2\nline 3\nline 4") + (goto-char (point-min)) + (jumper--do-store-location) ; ?0 @ line 1 + (forward-line 1) (jumper--do-store-location) ; ?1 @ line 2 + (let ((line3 (progn (forward-line 1) (point)))) + (jumper--do-store-location) ; ?2 @ line 3 + (jumper--do-remove-location 0) ; slot1 now holds ?2 @ line3 + (goto-char (point-max)) (jumper--do-store-location) ; reuse ?0 + (goto-char (point-min)) + (jumper--do-jump-to-location 1) ; slot1 = old line-3 marker + (should (= (point) line3)))) + (test-jumper-hyg-teardown))) + +(ert-deftest test-jumper-hyg-remove-clears-freed-register () + "Boundary: removing a location clears its register so the marker is freed." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "test") + (goto-char (point-min)) + (jumper--do-store-location) ; ?0 + (should (get-register ?0)) + (jumper--do-remove-location 0) + (should (null (get-register ?0)))) + (test-jumper-hyg-teardown))) + +;;; Defect 2 — dead-marker entries are skipped, not errored + +(ert-deftest test-jumper-hyg-with-marker-at-dead-buffer-returns-nil () + "Error: a marker whose buffer was killed yields nil, not a wrong-type error." + (test-jumper-hyg-setup) + (let ((buf (generate-new-buffer "jumper-dead-test"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "content") + (goto-char (point-min)) + (jumper--do-store-location)) ; ?0 points into buf + (kill-buffer buf) ; marker now detached + (should (null (jumper--with-marker-at 0 (lambda () 'ran))))) + (when (buffer-live-p buf) (kill-buffer buf)) + (test-jumper-hyg-teardown)))) + +(ert-deftest test-jumper-hyg-location-exists-p-survives-dead-buffer () + "Boundary: location-exists-p does not error when a stored buffer is dead." + (test-jumper-hyg-setup) + (let ((buf (generate-new-buffer "jumper-dead-test-2"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "content") + (goto-char (point-min)) + (jumper--do-store-location)) + (kill-buffer buf) + (should (null (jumper--location-exists-p)))) + (when (buffer-live-p buf) (kill-buffer buf)) + (test-jumper-hyg-teardown)))) + +(ert-deftest test-jumper-hyg-candidates-skip-dead-buffer () + "Boundary: the candidate list omits a location whose buffer was killed." + (test-jumper-hyg-setup) + (let ((buf (generate-new-buffer "jumper-dead-test-3"))) + (unwind-protect + (progn + (with-current-buffer buf + (insert "content") + (goto-char (point-min)) + (jumper--do-store-location)) + (kill-buffer buf) + (should (null (jumper--location-candidates)))) + (when (buffer-live-p buf) (kill-buffer buf)) + (test-jumper-hyg-teardown)))) + +;;; Defect 3 — single-location toggle returns to the previous spot + +(ert-deftest test-jumper-hyg-toggle-back-when-last-set () + "Normal: toggling at the only location jumps back to the last-location register. +Jump to the location (which records the prior spot in 'z); toggling again while +sitting on the location returns to that prior spot." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2\nline 3") + (goto-char (point-min)) + (jumper--do-store-location) ; store @ line 1 + (let ((away (point-max))) + (goto-char away) + (jumper--do-jump-to-location nil) ; jump to line 1, 'z := away + (should (= (point) (point-min))) + (let ((result (jumper--do-jump-to-location nil))) ; toggle back + (should (eq result 'jumped-back)) + (should (= (point) away))))) + (test-jumper-hyg-teardown))) + +(ert-deftest test-jumper-hyg-toggle-at-location-no-last-stays () + "Boundary: toggling at the location with no last-location set returns +'already-there and does not move point." + (test-jumper-hyg-setup) + (unwind-protect + (with-temp-buffer + (insert "line 1\nline 2") + (goto-char (point-min)) + (jumper--do-store-location) + (let ((result (jumper--do-jump-to-location nil))) + (should (eq result 'already-there)) + (should (= (point) (point-min))))) + (test-jumper-hyg-teardown))) + +(provide 'test-jumper--register-hygiene) +;;; test-jumper--register-hygiene.el ends here diff --git a/tests/test-keybindings--jump-open-var.el b/tests/test-keybindings--jump-open-var.el index bd04f4cf1..041f4a7d3 100644 --- a/tests/test-keybindings--jump-open-var.el +++ b/tests/test-keybindings--jump-open-var.el @@ -25,7 +25,7 @@ CAPTURE-VAR is set to the path passed to `find-file', or stays nil if the mock is never called." (declare (indent 1) (debug t)) `(cl-letf (((symbol-function 'find-file) - (lambda (path) (setq ,capture-var path)))) + (lambda (path &rest _) (setq ,capture-var path)))) ,@body)) (defmacro test-keybindings--with-fixture (value &rest body) diff --git a/tests/test-keybindings-tty-mirror.el b/tests/test-keybindings-tty-mirror.el new file mode 100644 index 000000000..f63024c0b --- /dev/null +++ b/tests/test-keybindings-tty-mirror.el @@ -0,0 +1,33 @@ +;;; test-keybindings-tty-mirror.el --- TTY mirror prefix for the C-; family -*- lexical-binding: t; -*- + +;;; Commentary: +;; The personal prefix C-; is GUI-only — terminals can't encode Control-semicolon, +;; so the whole custom command family is unreachable in a TTY frame (emacs -nw, +;; emacsclient -nw, Emacs inside vterm/tmux). keybindings.el binds the single +;; `cj/custom-keymap' under a TTY-safe mirror prefix C-c ; alongside C-;, so the +;; same leaf keys reach the identical map in both GUI and terminal. These tests +;; pin that load-time global binding. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'keybindings) + +(ert-deftest test-keybindings-tty-mirror-gui-prefix-resolves () + "Normal: the GUI prefix C-; resolves to cj/custom-keymap globally." + (should (eq (keymap-lookup (current-global-map) "C-;") cj/custom-keymap))) + +(ert-deftest test-keybindings-tty-mirror-tty-prefix-resolves () + "Normal: the TTY mirror C-c ; resolves to the same cj/custom-keymap." + (should (eq (keymap-lookup (current-global-map) "C-c ;") cj/custom-keymap))) + +(ert-deftest test-keybindings-tty-mirror-both-prefixes-share-one-map () + "Boundary: both prefixes point at the identical keymap object, so a leaf +key registered once is reachable under either prefix." + (should (eq (keymap-lookup (current-global-map) "C-;") + (keymap-lookup (current-global-map) "C-c ;")))) + +(provide 'test-keybindings-tty-mirror) +;;; test-keybindings-tty-mirror.el ends here diff --git a/tests/test-latex-config--latexmk-wiring.el b/tests/test-latex-config--latexmk-wiring.el new file mode 100644 index 000000000..30b8f29de --- /dev/null +++ b/tests/test-latex-config--latexmk-wiring.el @@ -0,0 +1,62 @@ +;;; test-latex-config--latexmk-wiring.el --- latexmk activation guards -*- lexical-binding: t; -*- + +;;; Commentary: +;; Guards the two breaks that kept the latexmk workflow from activating: +;; 1. The :hook entry that sets `TeX-command-default' must target the real +;; `TeX-mode-hook'. use-package appends "-hook" to any hook symbol not +;; ending in "-mode", so the mode name `TeX-mode' is required; the literal +;; `TeX-mode-hook' expands to the nonexistent `TeX-mode-hook-hook'. +;; 2. `auctex-latexmk' must load so `auctex-latexmk-setup' runs. `:defer t' +;; with no trigger never fires; `:after tex' loads it when AUCTeX loads. +;; +;; The forms are read from the source and macroexpanded, so the test fails the +;; way the live config failed -- against the actual declaration. + +;;; Code: + +(require 'ert) +(require 'seq) +(require 'use-package) + +(defun test-latex-config--forms () + "Return the top-level forms in latex-config.el." + (let ((file (expand-file-name "modules/latex-config.el" user-emacs-directory)) + (forms '())) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (condition-case nil + (while t (push (read (current-buffer)) forms)) + (end-of-file nil))) + (nreverse forms))) + +(defun test-latex-config--use-package-form (package) + "Return the (use-package PACKAGE ...) top-level form from latex-config.el." + (seq-find (lambda (form) + (and (consp form) + (eq (car form) 'use-package) + (eq (cadr form) package))) + (test-latex-config--forms))) + +(ert-deftest test-latex-config-tex-hook-targets-real-hook () + "Regression: the latexmk-default :hook expands to `TeX-mode-hook', not the +unbound `TeX-mode-hook-hook' use-package builds from a non-mode hook symbol." + (let* ((form (test-latex-config--use-package-form 'tex)) + (expansion (format "%S" (macroexpand-all form)))) + (should form) + ;; The hook symbol is followed by whitespace before its lambda, so anchor + ;; on that to distinguish `TeX-mode-hook' from the broken `...-hook-hook'. + (should (string-match-p "TeX-mode-hook[ )]" expansion)) + (should-not (string-match-p "TeX-mode-hook-hook" expansion)))) + +(ert-deftest test-latex-config-auctex-latexmk-loads-after-tex () + "Regression: auctex-latexmk uses `:after tex' so `auctex-latexmk-setup' runs; +a bare `:defer t' with no trigger would never load it." + (let ((form (test-latex-config--use-package-form 'auctex-latexmk))) + (should form) + (should (member :after form)) + (should (eq (cadr (member :after form)) 'tex)) + (should-not (member :defer form)))) + +(provide 'test-latex-config--latexmk-wiring) +;;; test-latex-config--latexmk-wiring.el ends here diff --git a/tests/test-local-repository--car-member.el b/tests/test-local-repository--car-member.el new file mode 100644 index 000000000..8b8c9a7db --- /dev/null +++ b/tests/test-local-repository--car-member.el @@ -0,0 +1,58 @@ +;;; test-local-repository--car-member.el --- Tests for car-member -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `car-member' in local-repository.el — the predicate +;; localrepo-initialize uses to check whether an archive id is already +;; registered in package-archives / package-archive-priorities. + +;;; Code: + +(require 'ert) +(require 'local-repository) + +;;; Normal Cases + +(ert-deftest test-local-repository-car-member-found () + "Normal: VALUE present as a car returns the matching tail (non-nil)." + (should (equal (car-member 'b '((a . 1) (b . 2) (c . 3))) + '(b c)))) + +(ert-deftest test-local-repository-car-member-not-found () + "Normal: VALUE absent from every car returns nil." + (should-not (car-member 'z '((a . 1) (b . 2))))) + +(ert-deftest test-local-repository-car-member-string-car () + "Normal: car comparison uses `equal', so string keys match by value." + (should (car-member "localrepo" + '(("gnu" . "url1") ("localrepo" . "url2"))))) + +;;; Boundary Cases + +(ert-deftest test-local-repository-car-member-empty-list () + "Boundary: an empty list never matches." + (should-not (car-member 'a nil))) + +(ert-deftest test-local-repository-car-member-single-match () + "Boundary: a single-element list whose car matches returns non-nil." + (should (car-member 'only '((only . 1))))) + +(ert-deftest test-local-repository-car-member-single-no-match () + "Boundary: a single-element list whose car differs returns nil." + (should-not (car-member 'x '((only . 1))))) + +(ert-deftest test-local-repository-car-member-nil-value-with-nil-car () + "Boundary: a nil VALUE matches a cons whose car is nil." + (should (car-member nil '((nil . 1) (a . 2))))) + +(ert-deftest test-local-repository-car-member-nil-value-no-nil-car () + "Boundary: a nil VALUE with no nil car returns nil." + (should-not (car-member nil '((a . 1) (b . 2))))) + +;;; Error Cases + +(ert-deftest test-local-repository-car-member-non-cons-element () + "Error: a non-cons element makes `car' signal wrong-type-argument." + (should-error (car-member 'x '(1 2)) :type 'wrong-type-argument)) + +(provide 'test-local-repository--car-member) +;;; test-local-repository--car-member.el ends here diff --git a/tests/test-mail-config--account-search-queries.el b/tests/test-mail-config--account-search-queries.el new file mode 100644 index 000000000..9f1b6b3e6 --- /dev/null +++ b/tests/test-mail-config--account-search-queries.el @@ -0,0 +1,53 @@ +;;; test-mail-config--account-search-queries.el --- Tests for the mail account-nav helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--mail-account-search-queries (pure: account name -> the four mu4e search +;; strings) and cj/--mail-make-account-map (builds the per-account nav keymap) +;; replace three near-identical defvar-keymap blocks that differed only by +;; maildir prefix. The map test invokes each binding with mu4e-search mocked, +;; which also verifies each loop-built closure captured its own query. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'mail-config) + +(ert-deftest test-mail-account-search-queries-cmail () + "Normal: the four searches are scoped to the account's INBOX maildir." + (should (equal (cj/--mail-account-search-queries "cmail") + '(("i" . "maildir:/cmail/INBOX") + ("u" . "maildir:/cmail/INBOX AND flag:unread AND NOT flag:trashed") + ("s" . "maildir:/cmail/INBOX AND flag:flagged") + ("l" . "maildir:/cmail/INBOX AND size:5M..999M"))))) + +(ert-deftest test-mail-account-search-queries-prefix-varies () + "Boundary: only the maildir prefix changes between accounts." + (should (equal (cdr (assoc "i" (cj/--mail-account-search-queries "dmail"))) + "maildir:/dmail/INBOX")) + (should (equal (cdr (assoc "i" (cj/--mail-account-search-queries "gmail"))) + "maildir:/gmail/INBOX"))) + +(ert-deftest test-mail-make-account-map-binds-four-keys () + "Normal: the built keymap binds i/u/s/l to commands." + (let ((map (cj/--mail-make-account-map "cmail"))) + (dolist (key '("i" "u" "s" "l")) + (should (commandp (keymap-lookup map key)))))) + +(ert-deftest test-mail-make-account-map-closures-capture-distinct-queries () + "Normal: each binding runs its own account-scoped search (no closure leak). +mu4e-search is mocked to capture the query each command passes." + (let ((searched '())) + (cl-letf (((symbol-function 'mu4e-search) + (lambda (q) (push q searched)))) + (let ((map (cj/--mail-make-account-map "dmail"))) + (funcall (keymap-lookup map "i")) + (funcall (keymap-lookup map "u")))) + (should (member "maildir:/dmail/INBOX" searched)) + (should (member "maildir:/dmail/INBOX AND flag:unread AND NOT flag:trashed" + searched)))) + +(provide 'test-mail-config--account-search-queries) +;;; test-mail-config--account-search-queries.el ends here diff --git a/tests/test-mail-config-refile-folder.el b/tests/test-mail-config-refile-folder.el new file mode 100644 index 000000000..e2d224eb6 --- /dev/null +++ b/tests/test-mail-config-refile-folder.el @@ -0,0 +1,40 @@ +;;; test-mail-config-refile-folder.el --- Tests for refile-folder dispatch -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/mu4e--refile-folder-for-maildir', the per-message refile +;; (archive) target dispatch. cmail has a real synced Archive folder; the +;; Gmail-backed accounts (gmail, dmail) have none, so refiling them must signal +;; rather than move mail into an unsynced, phantom folder (silent mail loss). + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'mail-config) + +(ert-deftest test-mail-config-refile-cmail-returns-archive () + "Normal: a cmail message refiles into the synced /cmail/Archive folder." + (should (string= (cj/mu4e--refile-folder-for-maildir "/cmail/INBOX") + "/cmail/Archive")) + (should (string= (cj/mu4e--refile-folder-for-maildir "/cmail/Sent") + "/cmail/Archive"))) + +(ert-deftest test-mail-config-refile-gmail-signals () + "Error: gmail has no synced archive folder, so refile signals rather than +moving mail into a phantom folder." + (should-error (cj/mu4e--refile-folder-for-maildir "/gmail/INBOX") + :type 'user-error)) + +(ert-deftest test-mail-config-refile-dmail-signals () + "Error: dmail (Gmail-backed) has no synced archive folder; refile signals." + (should-error (cj/mu4e--refile-folder-for-maildir "/dmail/INBOX") + :type 'user-error)) + +(ert-deftest test-mail-config-refile-nil-maildir-signals () + "Boundary: a message with no maildir cannot be refiled; signal." + (should-error (cj/mu4e--refile-folder-for-maildir nil) + :type 'user-error)) + +(provide 'test-mail-config-refile-folder) +;;; test-mail-config-refile-folder.el ends here diff --git a/tests/test-mail-config-transport.el b/tests/test-mail-config-transport.el index 2244b6dd2..0240102a2 100644 --- a/tests/test-mail-config-transport.el +++ b/tests/test-mail-config-transport.el @@ -18,7 +18,7 @@ EXECUTABLES is an alist of program name strings to executable paths." (declare (indent 1)) `(let (test-mail-config--warnings) (cl-letf (((symbol-function 'executable-find) - (lambda (program) + (lambda (program &rest _) (cdr (assoc program ,executables)))) ((symbol-function 'display-warning) (lambda (type message &rest _args) diff --git a/tests/test-markdown-config.el b/tests/test-markdown-config.el index 45e1a6018..edb20d357 100644 --- a/tests/test-markdown-config.el +++ b/tests/test-markdown-config.el @@ -9,6 +9,7 @@ ;;; Code: (require 'ert) +(require 'cl-lib) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) @@ -50,5 +51,14 @@ (should (string-match-p "<xmp" (buffer-string)))) (kill-buffer src)))) +;;; cj/markdown-preview (guard: refuse when the httpd listener is down) + +(ert-deftest test-markdown-preview-errors-when-server-down () + "Error: `cj/markdown-preview' signals a user-error when the simple-httpd +listener is not running, rather than opening a preview against a dead server. +Also pins the rename off the bare `markdown-preview' that markdown-mode shadows." + (cl-letf (((symbol-function 'httpd-running-p) (lambda () nil))) + (should-error (cj/markdown-preview) :type 'user-error))) + (provide 'test-markdown-config) ;;; test-markdown-config.el ends here diff --git a/tests/test-media-utils.el b/tests/test-media-utils.el index 9384d568f..841b6faf9 100644 --- a/tests/test-media-utils.el +++ b/tests/test-media-utils.el @@ -24,7 +24,7 @@ (ert-deftest test-media-get-available-players-filters-by-executable () "Normal: only players whose :command is on PATH are reported." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (and (member cmd '("mpv" "vlc")) cmd)))) + (lambda (cmd &rest _) (and (member cmd '("mpv" "vlc")) cmd)))) (let ((result (cj/get-available-media-players))) (should (memq 'mpv result)) (should (memq 'vlc result)) @@ -32,7 +32,7 @@ (ert-deftest test-media-get-available-players-none-installed () "Boundary: with nothing on PATH, the list is empty." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-not (cj/get-available-media-players)))) ;; ----------------------------- cj/media-play-it ------------------------------ @@ -41,7 +41,7 @@ "Normal: a player that needs no stream URL gets a plain command, no yt-dlp." (let (captured cj/default-media-player) (setq cj/default-media-player 'mpv) - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/mpv")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/mpv")) ((symbol-function 'start-process-shell-command) (lambda (_n _b cmd) (setq captured cmd) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) @@ -56,7 +56,7 @@ "Normal: a player needing a stream URL wraps the URL in a yt-dlp -g call." (let (captured cj/default-media-player) (setq cj/default-media-player 'vlc) - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/vlc")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/vlc")) ((symbol-function 'start-process-shell-command) (lambda (_n _b cmd) (setq captured cmd) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) @@ -71,7 +71,7 @@ "Error: an unavailable player command signals an error before launching." (let (cj/default-media-player) (setq cj/default-media-player 'mpv) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/media-play-it "https://example.com/v"))))) ;; ------------------------------- cj/yt-dl-it --------------------------------- @@ -79,19 +79,19 @@ (ert-deftest test-media-yt-dl-it-errors-without-yt-dlp () "Error: a missing yt-dlp aborts the download." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (unless (equal cmd "yt-dlp") "/usr/bin/x")))) + (lambda (cmd &rest _) (unless (equal cmd "yt-dlp") "/usr/bin/x")))) (should-error (cj/yt-dl-it "https://example.com/v")))) (ert-deftest test-media-yt-dl-it-errors-without-tsp () "Error: yt-dlp present but tsp missing aborts the download." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) (unless (equal cmd "tsp") "/usr/bin/x")))) + (lambda (cmd &rest _) (unless (equal cmd "tsp") "/usr/bin/x")))) (should-error (cj/yt-dl-it "https://example.com/v")))) (ert-deftest test-media-yt-dl-it-builds-tsp-yt-dlp-process () "Normal: with both tools present, the URL is queued via tsp + yt-dlp." (let (captured (videos-dir "/tmp/videos")) - (cl-letf (((symbol-function 'executable-find) (lambda (_) "/usr/bin/x")) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) ((symbol-function 'start-process) (lambda (&rest args) (setq captured args) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) diff --git a/tests/test-meta-subr-mock-arity.el b/tests/test-meta-subr-mock-arity.el new file mode 100644 index 000000000..8ee2cb5e0 --- /dev/null +++ b/tests/test-meta-subr-mock-arity.el @@ -0,0 +1,113 @@ +;;; test-meta-subr-mock-arity.el --- Guard against arity-narrow subr mocks -*- lexical-binding: t; -*- + +;;; Commentary: +;; A meta-test: it tests the other tests. Native compilation routes a +;; redefined C primitive (subr) through a trampoline that calls the +;; replacement with the primitive's FULL arity, filling optionals with nil. +;; So a fixed-arity mock that is narrower than the primitive throws +;; `wrong-number-of-arguments' the moment native-comp has compiled that +;; trampoline -- a failure that appears intermittently as the eln-cache fills. +;; +;; The rule this enforces is NOT "never mock a subr" (the suite mocks subrs +;; like `message' and `completing-read' hundreds of times, all fine). It is: +;; a mock of a C primitive must be able to accept the primitive's maximum +;; arity -- in practice, use (lambda (&rest _) ...). This test scans every +;; file under tests/ for `cl-letf' / `setf' / `fset' redefinitions of a +;; `symbol-function', and fails listing any whose replacement is too narrow. +;; +;; It is deterministic: a pure static read of the test sources plus +;; `func-arity', with no dependence on whether native-comp happens to have +;; built the trampoline yet. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'seq) + +(defconst test-meta-subr--test-dir + (expand-file-name "tests" (or (getenv "EMACS_CONFIG_ROOT") default-directory)) + "Directory whose .el files are scanned for subr mocks.") + +(defun test-meta-subr--replacement-arglist (repl) + "Return the formal arglist of REPL, or the symbol `unknown'. +Handles (lambda ARGS ...) and (function (lambda ARGS ...)); returns `variadic' +for forms known to accept any arity (`ignore', `always'), and `unknown' for +anything whose arity can't be read statically (a bare variable, a call)." + (pcase repl + (`(lambda ,args . ,_) args) + (`(function (lambda ,args . ,_)) args) + (`(quote ,(or 'ignore 'always)) 'variadic) + (`(function ,(or 'ignore 'always)) 'variadic) + (_ 'unknown))) + +(defun test-meta-subr--accepts-p (arglist subr-max) + "Non-nil if a lambda with ARGLIST can be called with SUBR-MAX positional args. +ARGLIST may also be `variadic' or `unknown' (both treated as acceptable)." + (cond + ((memq arglist '(variadic unknown)) t) + ((memq '&rest arglist) t) + ((eq subr-max 'many) nil) ; only &rest accepts unbounded arity + ((integerp subr-max) + (>= (length (seq-remove (lambda (s) (memq s '(&optional &rest &key))) + arglist)) + subr-max)) + (t t))) + +(defun test-meta-subr--quoted-symbol (form) + "If FORM is 'SYM or #'SYM, return SYM, else nil." + (pcase form + (`(quote ,(and s (guard (symbolp s)))) s) + (`(function ,(and s (guard (symbolp s)))) s))) + +(defun test-meta-subr--collect (form acc) + "Walk FORM, pushing (SYM . REPLACEMENT) for each symbol-function redefinition. +Covers `cl-letf'/`setf' binding shape ((symbol-function 'SYM) REPL) and +\(fset 'SYM REPL)." + (when (consp form) + ;; (fset 'SYM REPL) + (when (eq (car-safe form) 'fset) + (let ((s (test-meta-subr--quoted-symbol (nth 1 form)))) + (when s (push (cons s (nth 2 form)) acc)))) + ;; binding element ((symbol-function 'SYM) REPL) -- cl-letf, cl-letf*, setf + (when (and (consp (car-safe form)) + (eq (car-safe (car form)) 'symbol-function)) + (let ((s (test-meta-subr--quoted-symbol (nth 1 (car form))))) + (when s (push (cons s (nth 1 form)) acc)))) + (dolist (sub form) (setq acc (test-meta-subr--collect sub acc)))) + acc) + +(defun test-meta-subr--violations () + "Return a list of human-readable violation strings across the test files." + (let ((violations '())) + (dolist (file (directory-files-recursively test-meta-subr--test-dir "\\.el\\'")) + ;; Don't scan this meta-test itself (its examples would self-trip). + (unless (string-suffix-p "test-meta-subr-mock-arity.el" file) + (let ((mocks '())) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (condition-case nil + (while t (setq mocks (test-meta-subr--collect (read (current-buffer)) mocks))) + (error nil))) + (pcase-dolist (`(,sym . ,repl) (nreverse mocks)) + (when (and (fboundp sym) + (condition-case nil (subrp (symbol-function sym)) (error nil))) + (let ((subr-max (cdr (func-arity sym))) + (arglist (test-meta-subr--replacement-arglist repl))) + (unless (test-meta-subr--accepts-p arglist subr-max) + (push (format "%s: mock of subr `%s' (arity max %s) takes %S -- use (&rest _)" + (file-name-nondirectory file) sym subr-max arglist) + violations)))))))) + (nreverse violations))) + +(ert-deftest test-meta-no-arity-narrow-subr-mocks () + "No test mocks a C primitive with a lambda too narrow for its arity. +Such a mock breaks under native-comp's subr trampoline (it calls the mock with +the primitive's full arity). Fix by making the mock variadic: (lambda (&rest _) +...). See this file's commentary." + (let ((violations (test-meta-subr--violations))) + (should (null violations)))) + +(provide 'test-meta-subr-mock-arity) +;;; test-meta-subr-mock-arity.el ends here diff --git a/tests/test-modeline-config--click-map.el b/tests/test-modeline-config--click-map.el new file mode 100644 index 000000000..6c5ba4c7e --- /dev/null +++ b/tests/test-modeline-config--click-map.el @@ -0,0 +1,29 @@ +;;; test-modeline-config--click-map.el --- Tests for cj/--modeline-click-map -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--modeline-click-map is the shared mode-line `local-map' builder extracted +;; from three clickable segments (buffer-name, vc, major-mode) that each spelled +;; out the same make-sparse-keymap + define-key dance. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'modeline-config) + +(ert-deftest test-modeline-click-map-binds-mouse-1-and-3 () + "Normal: with both commands, mouse-1 and mouse-3 are bound." + (let ((map (cj/--modeline-click-map 'vc-diff 'vc-root-diff))) + (should (keymapp map)) + (should (eq (lookup-key map [mode-line mouse-1]) 'vc-diff)) + (should (eq (lookup-key map [mode-line mouse-3]) 'vc-root-diff)))) + +(ert-deftest test-modeline-click-map-mouse-1-only () + "Boundary: with no MOUSE-3, only mouse-1 is bound." + (let ((map (cj/--modeline-click-map 'describe-mode))) + (should (eq (lookup-key map [mode-line mouse-1]) 'describe-mode)) + (should (null (lookup-key map [mode-line mouse-3]))))) + +(provide 'test-modeline-config--click-map) +;;; test-modeline-config--click-map.el ends here diff --git a/tests/test-modeline-config-flycheck-segment.el b/tests/test-modeline-config-flycheck-segment.el index 208deaa72..2ae2f5de1 100644 --- a/tests/test-modeline-config-flycheck-segment.el +++ b/tests/test-modeline-config-flycheck-segment.el @@ -5,7 +5,7 @@ ;; a guarded reference to `flycheck-mode-line-status-text', and that ;; the guard requires both `mode-line-window-selected-p' and ;; `bound-and-true-p flycheck-mode'. See -;; docs/design/flycheck-modeline-customization.org for the design. +;; docs/specs/flycheck-modeline-customization-spec-implemented.org for the design. ;;; Code: diff --git a/tests/test-modeline-config-string-cut-middle.el b/tests/test-modeline-config-string-cut-middle.el index 40cc0bccc..d68431b49 100644 --- a/tests/test-modeline-config-string-cut-middle.el +++ b/tests/test-modeline-config-string-cut-middle.el @@ -17,14 +17,6 @@ ;; Add modules directory to load path (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -;; Stub dependencies before loading the module -(unless (boundp 'cj/buffer-status-colors) - (defvar cj/buffer-status-colors - '((unmodified . "#FFFFFF") - (modified . "#00FF00") - (read-only . "#FF0000") - (overwrite . "#FFD700")))) - (require 'modeline-config) ;;; Test Helpers diff --git a/tests/test-modeline-config-string-truncate-p.el b/tests/test-modeline-config-string-truncate-p.el index 09378b0d1..94ea74171 100644 --- a/tests/test-modeline-config-string-truncate-p.el +++ b/tests/test-modeline-config-string-truncate-p.el @@ -19,14 +19,6 @@ ;; Add modules directory to load path (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -;; Stub dependencies before loading the module -(unless (boundp 'cj/buffer-status-colors) - (defvar cj/buffer-status-colors - '((unmodified . "#FFFFFF") - (modified . "#00FF00") - (read-only . "#FF0000") - (overwrite . "#FFD700")))) - (require 'modeline-config) ;;; Test Helpers diff --git a/tests/test-modeline-config-vc-cache-key.el b/tests/test-modeline-config-vc-cache-key.el index ae869f4b8..6ba7985c2 100644 --- a/tests/test-modeline-config-vc-cache-key.el +++ b/tests/test-modeline-config-vc-cache-key.el @@ -1,56 +1,36 @@ ;;; test-modeline-config-vc-cache-key.el --- Tests for VC modeline cache key -*- lexical-binding: t; -*- ;;; Commentary: -;; The VC modeline cache keys on the file. A symlink whose target moves to a -;; different VC tree must invalidate the cache, so the key includes the -;; resolved `file-truename', not just the symlink path. +;; The VC modeline cache keys on the file path and the `cj/modeline-vc-show-remote' +;; flag only. `file-truename' is deliberately NOT in the key: it would run on +;; every redisplay (the mode-line rebuilds the key each render to check validity), +;; and a moved symlink target is picked up at the next TTL refresh anyway, since +;; `vc-backend' resolves the link fresh. The per-render stat isn't worth it. ;;; Code: (require 'ert) -(require 'cl-lib) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'modeline-config) -;;; Normal Cases - -(ert-deftest test-modeline-vc-cache-key-includes-truename () - "Normal: the cache key includes the resolved truename of the file." - (let ((f (make-temp-file "cj-mlkey-"))) - (unwind-protect - (should (member (file-truename f) (cj/modeline-vc-cache-key f))) - (delete-file f)))) - -;;; Boundary Cases - -(ert-deftest test-modeline-vc-cache-key-changes-when-symlink-target-moves () - "Boundary: re-pointing a symlink to a new target changes the cache key. -The symlink path is identical both times; only its truename differs, so a -key that ignored the truename would serve a stale VC backend." - (let* ((dir (make-temp-file "cj-mlkey-dir-" t)) - (target-a (expand-file-name "a" dir)) - (target-b (expand-file-name "b" dir)) - (link (expand-file-name "link" dir))) - (unwind-protect - (progn - (write-region "" nil target-a) - (write-region "" nil target-b) - (make-symbolic-link target-a link) - (let ((key-a (cj/modeline-vc-cache-key link))) - (delete-file link) - (make-symbolic-link target-b link) - (let ((key-b (cj/modeline-vc-cache-key link))) - (should-not (equal key-a key-b))))) - (delete-directory dir t)))) +(ert-deftest test-modeline-vc-cache-key-is-file-and-show-remote () + "Normal: the key is (FILE SHOW-REMOTE), with no per-render file-truename stat." + (let ((cj/modeline-vc-show-remote nil)) + (should (equal (cj/modeline-vc-cache-key "/x/y.el") '("/x/y.el" nil))))) + +(ert-deftest test-modeline-vc-cache-key-tracks-show-remote () + "Boundary: toggling show-remote yields a different key (separate cache entry)." + (should-not (equal (let ((cj/modeline-vc-show-remote nil)) + (cj/modeline-vc-cache-key "/x/y.el")) + (let ((cj/modeline-vc-show-remote t)) + (cj/modeline-vc-cache-key "/x/y.el"))))) (ert-deftest test-modeline-vc-cache-key-stable-for-same-file () - "Boundary: the key is stable across calls for an unchanged file." - (let ((f (make-temp-file "cj-mlkey-stable-"))) - (unwind-protect - (should (equal (cj/modeline-vc-cache-key f) - (cj/modeline-vc-cache-key f))) - (delete-file f)))) + "Boundary: the key is stable across calls for an unchanged file + show-remote." + (let ((cj/modeline-vc-show-remote nil)) + (should (equal (cj/modeline-vc-cache-key "/x/y.el") + (cj/modeline-vc-cache-key "/x/y.el"))))) (provide 'test-modeline-config-vc-cache-key) ;;; test-modeline-config-vc-cache-key.el ends here diff --git a/tests/test-modeline-config-vc-cache.el b/tests/test-modeline-config-vc-cache.el index b6aafbfbe..dab755442 100644 --- a/tests/test-modeline-config-vc-cache.el +++ b/tests/test-modeline-config-vc-cache.el @@ -98,5 +98,12 @@ (should (text-property-any 0 (length rendered) 'mouse-face 'mode-line-highlight rendered))))) +(ert-deftest test-modeline-config-vc-fetch-swallows-vc-errors () + "Error: a signal from the VC backend is swallowed (returns nil) rather than +propagating into the mode-line redisplay path, where it would break all redisplay." + (cl-letf (((symbol-function 'file-remote-p) (lambda (&rest _) nil)) + ((symbol-function 'vc-backend) (lambda (&rest _) (error "git boom")))) + (should (null (cj/modeline-vc-fetch "/tmp/project/file.el"))))) + (provide 'test-modeline-config-vc-cache) ;;; test-modeline-config-vc-cache.el ends here diff --git a/tests/test-mousetrap-mode--bind-events.el b/tests/test-mousetrap-mode--bind-events.el new file mode 100644 index 000000000..6772d6fa3 --- /dev/null +++ b/tests/test-mousetrap-mode--bind-events.el @@ -0,0 +1,41 @@ +;;; test-mousetrap-mode--bind-events.el --- Tests for mouse-trap--bind-events-to-ignore -*- lexical-binding: t; -*- + +;;; Commentary: +;; mouse-trap--bind-events-to-ignore is the per-category binding loop extracted +;; from mouse-trap--build-keymap-1 (which previously nested it five deep). It +;; binds a category's events, across modifier prefixes, to `ignore'. The full +;; keymap build stays covered by test-mousetrap-mode--build-keymap.el. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'mousetrap-mode) + +(ert-deftest test-mousetrap-bind-events-wheel () + "Normal: wheel events are bound to ignore across every prefix variant." + (let ((map (make-sparse-keymap)) + (spec '((wheel . ("wheel-up" "wheel-down"))))) + (mouse-trap--bind-events-to-ignore spec '("" "C-") map) + (should (eq (lookup-key map (kbd "<wheel-up>")) #'ignore)) + (should (eq (lookup-key map (kbd "<C-wheel-up>")) #'ignore)) + (should (eq (lookup-key map (kbd "<wheel-down>")) #'ignore)))) + +(ert-deftest test-mousetrap-bind-events-click () + "Normal: type x button click events are bound to ignore." + (let ((map (make-sparse-keymap)) + (spec '((types . ("mouse" "down-mouse")) (buttons . (1 3))))) + (mouse-trap--bind-events-to-ignore spec '("") map) + (should (eq (lookup-key map (kbd "<mouse-1>")) #'ignore)) + (should (eq (lookup-key map (kbd "<mouse-3>")) #'ignore)) + (should (eq (lookup-key map (kbd "<down-mouse-1>")) #'ignore)))) + +(ert-deftest test-mousetrap-bind-events-empty-spec-no-op () + "Boundary: a spec with neither wheel nor types/buttons binds nothing." + (let ((map (make-sparse-keymap))) + (mouse-trap--bind-events-to-ignore '((other . t)) '("") map) + (should (null (lookup-key map (kbd "<mouse-1>")))))) + +(provide 'test-mousetrap-mode--bind-events) +;;; test-mousetrap-mode--bind-events.el ends here diff --git a/tests/test-music-config--playlist-side.el b/tests/test-music-config--playlist-side.el new file mode 100644 index 000000000..f49694690 --- /dev/null +++ b/tests/test-music-config--playlist-side.el @@ -0,0 +1,45 @@ +;;; test-music-config--playlist-side.el --- Tests for the F10 dock-side helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--music-playlist-side' maps the shared dock rule's verdict to a +;; `display-buffer-in-side-window' side: `right' stays `right', anything +;; else becomes `bottom'. The decision itself lives in +;; `cj/preferred-dock-direction' (tested in test-cj-window-geometry-lib.el); +;; here we stub it (an ordinary defun -- safe to `cl-letf', unlike the +;; frame-* subrs) to prove the mapping and that the width fraction is +;; passed through. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'music-config) + +(ert-deftest test-music-config--playlist-side-right-verdict-is-right () + "Normal: a `right' verdict from the dock rule docks the playlist right." + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (&rest _) 'right))) + (should (eq (cj/--music-playlist-side) 'right)))) + +(ert-deftest test-music-config--playlist-side-below-verdict-is-bottom () + "Normal: a `below' verdict maps to the `bottom' side window." + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (&rest _) 'below))) + (should (eq (cj/--music-playlist-side) 'bottom)))) + +(ert-deftest test-music-config--playlist-side-passes-width-fraction () + "Normal: the playlist's width fraction reaches the dock rule." + (let ((cj/music-playlist-window-width 0.4) + captured) + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (cols frac &rest _) + (setq captured (list cols frac)) + 'below))) + (cj/--music-playlist-side) + (should (= (nth 1 captured) 0.4)) + (should (integerp (nth 0 captured)))))) + +(provide 'test-music-config--playlist-side) +;;; test-music-config--playlist-side.el ends here diff --git a/tests/test-music-config-commands.el b/tests/test-music-config-commands.el index d57e339c4..3c585d0b7 100644 --- a/tests/test-music-config-commands.el +++ b/tests/test-music-config-commands.el @@ -176,9 +176,9 @@ last-played track and starts it." (added-hooks nil) (removed-hooks nil)) (cl-letf (((symbol-function 'add-hook) - (lambda (hook _fn) (push hook added-hooks))) + (lambda (hook _fn &rest _) (push hook added-hooks))) ((symbol-function 'remove-hook) - (lambda (hook _fn) (push hook removed-hooks))) + (lambda (hook _fn &rest _) (push hook removed-hooks))) ((symbol-function 'message) #'ignore)) (cj/music-toggle-consume) (should cj/music-consume-mode) diff --git a/tests/test-music-config-helpers-untested.el b/tests/test-music-config-helpers-untested.el index 4ba0940a5..bfdb2634d 100644 --- a/tests/test-music-config-helpers-untested.el +++ b/tests/test-music-config-helpers-untested.el @@ -113,7 +113,7 @@ test prelude inserts filler with `inhibit-read-only' bound." "Normal: when emms is already a feature, setup does not re-require." (let ((called nil)) (cl-letf (((symbol-function 'featurep) - (lambda (sym) (eq sym 'emms))) + (lambda (sym &rest _) (eq sym 'emms))) ((symbol-function 'require) (lambda (&rest _) (setq called t) t))) (cj/emms--setup)) @@ -123,7 +123,7 @@ test prelude inserts filler with `inhibit-read-only' bound." "Boundary: when emms isn't yet loaded, setup requires it." (let ((required nil)) (cl-letf (((symbol-function 'featurep) - (lambda (sym) (not (eq sym 'emms)))) + (lambda (sym &rest _) (not (eq sym 'emms)))) ((symbol-function 'require) (lambda (feat &rest _) (setq required feat) t))) (cj/emms--setup)) diff --git a/tests/test-music-config-more-commands.el b/tests/test-music-config-more-commands.el index a029a5a33..c351c1f15 100644 --- a/tests/test-music-config-more-commands.el +++ b/tests/test-music-config-more-commands.el @@ -94,7 +94,7 @@ ((symbol-function 'cj/music--playlist-modified-p) (lambda () nil)) ((symbol-function 'find-file-other-window) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (cj/music-playlist-edit)) (delete-file tmp)) (should (equal opened tmp)))) @@ -130,7 +130,7 @@ ((symbol-function 'cj/music--ensure-playlist-buffer) (lambda () buf)) ((symbol-function 'switch-to-buffer) - (lambda (b) (setq switched b))) + (lambda (b &rest _) (setq switched b))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) (cj/music-playlist-show)) diff --git a/tests/test-music-config-playlist-commands.el b/tests/test-music-config-playlist-commands.el index 3d6dfd8b9..891bc700c 100644 --- a/tests/test-music-config-playlist-commands.el +++ b/tests/test-music-config-playlist-commands.el @@ -132,7 +132,7 @@ (cl-letf (((symbol-function 'cj/music--playlist-modified-p) (lambda () nil)) ((symbol-function 'find-file-other-window) - (lambda (p) (setq opened p)))) + (lambda (p &rest _) (setq opened p)))) (cj/music-playlist-edit)) (should (equal opened tmp)) (delete-file tmp)) diff --git a/tests/test-nerd-icons-config--apply-tint.el b/tests/test-nerd-icons-config--apply-tint.el deleted file mode 100644 index ef723352c..000000000 --- a/tests/test-nerd-icons-config--apply-tint.el +++ /dev/null @@ -1,63 +0,0 @@ -;;; test-nerd-icons-config--apply-tint.el --- Tests for cj/nerd-icons-apply-tint -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for the bulk-tint helper. Mocks `set-face-foreground' and `facep' -;; at the framework boundary so the tests don't depend on nerd-icons being -;; loaded — only on the symbol list and the dispatch logic. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'nerd-icons-config) - -(defmacro test-nerd-icons-config--capture-set-face-foreground (calls-var &rest body) - "Run BODY with `set-face-foreground' and `facep' stubbed. -Each (face color) pair gets pushed onto CALLS-VAR. `facep' returns t -for every symbol so all faces in the list count as defined." - (declare (indent 1) (debug t)) - `(cl-letf (((symbol-function 'set-face-foreground) - (lambda (face color &rest _) (push (cons face color) ,calls-var))) - ((symbol-function 'facep) - (lambda (_) t))) - ,@body)) - -(ert-deftest test-nerd-icons-config--apply-tint-covers-every-face () - "Normal: apply-tint calls set-face-foreground once per face in the list." - (let ((calls nil)) - (test-nerd-icons-config--capture-set-face-foreground calls - (cj/nerd-icons-apply-tint "test-color")) - (should (= (length calls) (length cj/--nerd-icons-color-faces))) - (dolist (face cj/--nerd-icons-color-faces) - (should (assq face calls))))) - -(ert-deftest test-nerd-icons-config--apply-tint-passes-color-arg () - "Normal: apply-tint forwards COLOR to every set-face-foreground call." - (let ((calls nil)) - (test-nerd-icons-config--capture-set-face-foreground calls - (cj/nerd-icons-apply-tint "rebeccapurple")) - (dolist (call calls) - (should (equal (cdr call) "rebeccapurple"))))) - -(ert-deftest test-nerd-icons-config--apply-tint-defaults-to-customvar () - "Normal: with no COLOR arg, uses `cj/nerd-icons-tint-color'." - (let ((calls nil)) - (test-nerd-icons-config--capture-set-face-foreground calls - (let ((cj/nerd-icons-tint-color "default-test-color")) - (cj/nerd-icons-apply-tint))) - (should (cl-every (lambda (call) (equal (cdr call) "default-test-color")) calls)))) - -(ert-deftest test-nerd-icons-config--apply-tint-skips-undefined-faces () - "Boundary: faces that fail `facep' are silently skipped, not errored." - (let ((calls nil)) - (cl-letf (((symbol-function 'set-face-foreground) - (lambda (face color &rest _) (push (cons face color) calls))) - ((symbol-function 'facep) - (lambda (_) nil))) - (cj/nerd-icons-apply-tint "any")) - (should (null calls)))) - -(provide 'test-nerd-icons-config--apply-tint) -;;; test-nerd-icons-config--apply-tint.el ends here diff --git a/tests/test-nerd-icons-config--color-dir.el b/tests/test-nerd-icons-config--color-dir.el index 808c0dc34..2ae64a810 100644 --- a/tests/test-nerd-icons-config--color-dir.el +++ b/tests/test-nerd-icons-config--color-dir.el @@ -53,5 +53,20 @@ renders would stack `nerd-icons-yellow' over and over on the cached string." (yellows (cl-count 'nerd-icons-yellow specs))) (should (= yellows 1))))) +(ert-deftest test-nerd-icons-config--color-dir-precedence-over-completion-face () + "Normal: when the dir icon already carries nerd-icons-completion-dir-face +\(what `nerd-icons-completion-get-icon' passes), the advice prepends +nerd-icons-yellow so it is first in the face list and wins the merge. Locks +the dir-precedence decision: the prepended advice face outranks the package's +:face, even though that face lives in a different package." + (let* ((icon (propertize "X" 'face 'nerd-icons-completion-dir-face)) + (result (cj/--nerd-icons-color-dir icon)) + (faces (ensure-list (get-text-property 0 'face result)))) + (should (memq 'nerd-icons-yellow faces)) + (should (memq 'nerd-icons-completion-dir-face faces)) + (should (= 0 (cl-position 'nerd-icons-yellow faces))) + (should (< (cl-position 'nerd-icons-yellow faces) + (cl-position 'nerd-icons-completion-dir-face faces))))) + (provide 'test-nerd-icons-config--color-dir) ;;; test-nerd-icons-config--color-dir.el ends here diff --git a/tests/test-org-agenda-config--base-files.el b/tests/test-org-agenda-config--base-files.el new file mode 100644 index 000000000..bd202a195 --- /dev/null +++ b/tests/test-org-agenda-config--base-files.el @@ -0,0 +1,59 @@ +;;; test-org-agenda-config--base-files.el --- Tests for the agenda base-file helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--org-agenda-base-files is the single source of the fixed agenda base list +;; (inbox, schedule, and the three calendars) that was previously spelled out as +;; a literal in three places. It now drops files that do not exist so org-agenda +;; never prompts to create a missing path (the hang class). The path vars are +;; special (defvar'd in user-constants), so they can be dynamically bound; tests +;; use real temp files for "exists" rather than mocking the `file-exists-p' +;; primitive. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-agenda-config) + +(defun test-oa-base--tmp () + "Return a fresh existing temp file path." + (make-temp-file "oa-base-")) + +(ert-deftest test-org-agenda-base-files-returns-existing-in-order () + "Normal: returns inbox, schedule, gcal, pcal, dcal (all existing) in order." + (let* ((i (test-oa-base--tmp)) (s (test-oa-base--tmp)) (g (test-oa-base--tmp)) + (p (test-oa-base--tmp)) (d (test-oa-base--tmp)) + (inbox-file i) (schedule-file s) (gcal-file g) (pcal-file p) (dcal-file d)) + (unwind-protect + (should (equal (cj/--org-agenda-base-files) (list i s g p d))) + (dolist (f (list i s g p d)) (ignore-errors (delete-file f)))))) + +(ert-deftest test-org-agenda-base-files-reflects-current-values () + "Boundary: the helper reads the vars at call time (not a captured snapshot)." + (let* ((a (test-oa-base--tmp)) (b (test-oa-base--tmp)) + (inbox-file a) (schedule-file b) (gcal-file b) (pcal-file b) (dcal-file b)) + (unwind-protect + (progn + (should (equal (car (cj/--org-agenda-base-files)) a)) + (setq inbox-file b) + (should (equal (car (cj/--org-agenda-base-files)) b)) + (should (= (length (cj/--org-agenda-base-files)) 5))) + (ignore-errors (delete-file a)) + (ignore-errors (delete-file b))))) + +(ert-deftest test-org-agenda-base-files-drops-missing-files () + "Boundary/Error: files that do not exist are dropped, so a fresh machine +without synced calendars never hands org-agenda a path it would prompt to create." + (let* ((i (test-oa-base--tmp)) (s (test-oa-base--tmp)) + (inbox-file i) (schedule-file s) + (gcal-file "/no/such/gcal.org") + (pcal-file "/no/such/pcal.org") + (dcal-file "/no/such/dcal.org")) + (unwind-protect + (should (equal (cj/--org-agenda-base-files) (list i s))) + (ignore-errors (delete-file i)) + (ignore-errors (delete-file s))))) + +(provide 'test-org-agenda-config--base-files) +;;; test-org-agenda-config--base-files.el ends here diff --git a/tests/test-org-agenda-config-commands.el b/tests/test-org-agenda-config-commands.el index e29871b79..76407439d 100644 --- a/tests/test-org-agenda-config-commands.el +++ b/tests/test-org-agenda-config-commands.el @@ -145,6 +145,24 @@ calling `org-agenda'." (should build-called) (should (equal agenda-args '("a" "d"))))) +;;; org-agenda-custom-commands "d" daily structure + +(defun test-org-agenda--daily-blocks () + "Return the block list of the \"d\" daily agenda command." + (nth 2 (assoc "d" org-agenda-custom-commands))) + +(ert-deftest test-org-agenda-daily-schedule-block-is-first () + "Normal: the schedule (calendar) block leads the daily agenda." + (should (eq (car (nth 0 (test-org-agenda--daily-blocks))) 'agenda))) + +(ert-deftest test-org-agenda-daily-has-no-overdue-block () + "Normal: no overdue block. It duplicated the past-due +scheduled/deadline items the schedule block already surfaces on +today's line (org-scheduled-past-days/org-deadline-past-days are +large), so the standalone OVERDUE section was redundant." + (let ((flat (flatten-tree (test-org-agenda--daily-blocks)))) + (should-not (memq 'cj/org-agenda-skip-subtree-if-not-overdue flat)))) + ;;; cj/add-timestamp-to-org-entry (ert-deftest test-org-agenda-add-timestamp-inserts-on-next-line () diff --git a/tests/test-org-agenda-config-skip-functions.el b/tests/test-org-agenda-config-skip-functions.el index aec1e71be..b8290da21 100644 --- a/tests/test-org-agenda-config-skip-functions.el +++ b/tests/test-org-agenda-config-skip-functions.el @@ -145,76 +145,6 @@ Suppresses org-mode hooks to avoid loading packages not available in batch." (test-org-agenda--with-org-buffer "* DONE Finished task\n" (should (integerp (cj/org-skip-subtree-if-keyword '("TODO" "DONE" "CANCELLED")))))) -;;; ---------- cj/org-agenda-skip-subtree-if-not-overdue ---------- - -;;; Normal Cases - -(ert-deftest test-org-agenda-config-skip-overdue-normal-past-scheduled-keeps () - "Entry scheduled in the past with TODO keyword is overdue — keep it." - (test-org-agenda--with-org-buffer - (concat "* TODO Overdue task\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n") - (should (null (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-future-scheduled-skips () - "Entry scheduled in the future is not overdue — skip it." - (test-org-agenda--with-org-buffer - (concat "* TODO Future task\n" - "SCHEDULED: " (test-org-timestamp-days-ahead 7) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-past-deadline-keeps () - "Entry with past deadline and TODO keyword is overdue — keep it." - (test-org-agenda--with-org-buffer - (concat "* TODO Missed deadline\n" - "DEADLINE: " (test-org-timestamp-days-ago 3) "\n") - (should (null (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-done-task-skips () - "Done task should be skipped even if overdue." - (test-org-agenda--with-org-buffer - (concat "* DONE Completed task\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-habit-skips () - "Habit should be skipped even if overdue." - (test-org-agenda--with-org-buffer - (concat "* TODO Daily habit\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n" - ":PROPERTIES:\n" - ":STYLE: habit\n" - ":END:\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-normal-no-todo-keyword-skips () - "Entry without a TODO keyword should be skipped." - (test-org-agenda--with-org-buffer - (concat "* Just a heading\n" - "SCHEDULED: " (test-org-timestamp-days-ago 7) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -;;; Boundary Cases - -(ert-deftest test-org-agenda-config-skip-overdue-boundary-today-scheduled-skips () - "Entry scheduled today is NOT overdue (not strictly before today) — skip." - (test-org-agenda--with-org-buffer - (concat "* TODO Today task\n" - "SCHEDULED: " (test-org-timestamp-today) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-boundary-no-date-skips () - "Entry with TODO but no scheduled/deadline date — not overdue, skip." - (test-org-agenda--with-org-buffer "* TODO Undated task\n" - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - -(ert-deftest test-org-agenda-config-skip-overdue-boundary-future-deadline-skips () - "Entry with future deadline is not overdue — skip." - (test-org-agenda--with-org-buffer - (concat "* TODO Future deadline\n" - "DEADLINE: " (test-org-timestamp-days-ahead 14) "\n") - (should (integerp (cj/org-agenda-skip-subtree-if-not-overdue))))) - ;;; ---------- "d" command SCHEDULE block: CANCELLED skip ---------- ;;; Normal Cases @@ -268,17 +198,18 @@ regression where one block diverges from the others on the format." ;;; Normal Cases -(ert-deftest test-org-agenda-config-d-command-has-six-blocks-in-expected-order () - "Normal: the \"d\" command runs six blocks in the expected order -- -OVERDUE -> HIGH PRIORITY -> VERIFICATION -> SCHEDULE -> IN-PROGRESS -> PRIORITY B." +(ert-deftest test-org-agenda-config-d-command-has-five-blocks-in-expected-order () + "Normal: the \"d\" command runs five blocks in the expected order -- +SCHEDULE -> HIGH PRIORITY -> VERIFICATION -> IN-PROGRESS -> PRIORITY B. +The schedule (calendar) leads; the former OVERDUE block was dropped +because it duplicated the past-due items the schedule already shows." (let* ((entry (assoc "d" org-agenda-custom-commands)) (blocks (nth 2 entry)) (shapes (mapcar (lambda (b) (list (car b) (cadr b))) blocks))) (should (equal shapes - '((alltodo "") + '((agenda "") (tags "PRIORITY=\"A\"") (todo "VERIFY") - (agenda "") (todo "DOING") (alltodo "")))))) diff --git a/tests/test-org-capture-config--find-or-create-top-heading.el b/tests/test-org-capture-config--find-or-create-top-heading.el new file mode 100644 index 000000000..236c87c87 --- /dev/null +++ b/tests/test-org-capture-config--find-or-create-top-heading.el @@ -0,0 +1,45 @@ +;;; test-org-capture-config--find-or-create-top-heading.el --- Tests for the shared find-or-create helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--org-find-or-create-top-heading is the search-or-append positioning block +;; extracted from cj/org-capture--goto-file-headline, cj/--org-capture-goto-open-work, +;; and cj/--org-capture-goto-exact-headline. The three call sites stay covered by +;; test-org-capture-config-project-target.el (open-work, exact-headline) and the +;; target-cache test; these cover the generic helper directly with a plain regexp +;; (so the test doesn't depend on org's complex-heading format). + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-capture-config) + +(ert-deftest test-org-find-or-create-top-heading-finds-existing () + "Normal: an existing heading is found; point lands at its line start and the +buffer is unchanged." + (with-temp-buffer + (insert "* Alpha\nbody\n* Target\nmore\n") + (cj/--org-find-or-create-top-heading "^\\* Target$" "* Target") + (should (looking-at-p "\\* Target$")) + (should (equal (buffer-string) "* Alpha\nbody\n* Target\nmore\n")))) + +(ert-deftest test-org-find-or-create-top-heading-creates-when-absent () + "Boundary: with no match, the heading line is appended (a separating newline +added because the buffer doesn't end in one) and point lands on it." + (with-temp-buffer + (insert "some text") ; no trailing newline + (cj/--org-find-or-create-top-heading "^\\* Missing$" "* Missing") + (should (equal (buffer-string) "some text\n* Missing\n")) + (should (looking-at-p "\\* Missing$")))) + +(ert-deftest test-org-find-or-create-top-heading-empty-buffer () + "Boundary: in an empty buffer the heading is inserted at the top, no extra +leading newline." + (with-temp-buffer + (cj/--org-find-or-create-top-heading "^\\* X$" "* X") + (should (equal (buffer-string) "* X\n")) + (should (looking-at-p "\\* X$")))) + +(provide 'test-org-capture-config--find-or-create-top-heading) +;;; test-org-capture-config--find-or-create-top-heading.el ends here diff --git a/tests/test-org-capture-config-popup-window.el b/tests/test-org-capture-config-popup-window.el new file mode 100644 index 000000000..671d55ab9 --- /dev/null +++ b/tests/test-org-capture-config-popup-window.el @@ -0,0 +1,195 @@ +;;; test-org-capture-config-popup-window.el --- Quick-capture popup tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the Hyprland Super+Shift+N quick-capture popup. The popup opens an +;; emacsclient frame named "org-capture" and runs `cj/quick-capture', which +;; captures a single Task into the global inbox with no template menu. Covered +;; here: the sole-window predicate and display action (the CAPTURE-* buffer +;; fills the frame), the single-Task template builder, frame discovery and focus +;; (the emacsclient focus race), and frame cleanup on every exit path. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'org) +(require 'org-capture) ; makes `org-capture-templates' a real special var +(require 'user-constants) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-capture-config) + +;;; cj/org-capture--popup-sole-window-p + +(ert-deftest test-org-capture-config-popup-sole-window-p-select-menu () + "Normal: the *Org Select* menu in the popup frame wants the sole window." + (should (cj/org-capture--popup-sole-window-p "org-capture" "*Org Select*"))) + +(ert-deftest test-org-capture-config-popup-sole-window-p-capture-buffer () + "Normal: a CAPTURE-* buffer in the popup frame wants the sole window." + (should (cj/org-capture--popup-sole-window-p "org-capture" "CAPTURE-todo.org"))) + +(ert-deftest test-org-capture-config-popup-sole-window-p-capture-prefix-only () + "Boundary: the bare \"CAPTURE-\" prefix still matches." + (should (cj/org-capture--popup-sole-window-p "org-capture" "CAPTURE-"))) + +(ert-deftest test-org-capture-config-popup-sole-window-p-other-frame () + "Boundary: the same menu in a normal frame is left alone." + (should-not (cj/org-capture--popup-sole-window-p "emacs" "*Org Select*")) + (should-not (cj/org-capture--popup-sole-window-p nil "CAPTURE-todo.org"))) + +(ert-deftest test-org-capture-config-popup-sole-window-p-other-buffer () + "Boundary: an unrelated buffer in the popup frame is left alone." + (should-not (cj/org-capture--popup-sole-window-p "org-capture" "todo.org")) + (should-not (cj/org-capture--popup-sole-window-p "org-capture" "*scratch*"))) + +(ert-deftest test-org-capture-config-popup-sole-window-p-nil-buffer () + "Error: a nil or non-string buffer name returns nil without raising." + (should-not (cj/org-capture--popup-sole-window-p "org-capture" nil)) + (should-not (cj/org-capture--popup-sole-window-p "org-capture" 42))) + +;;; Integration: the display-buffer-alist entry routes to a sole window + +(ert-deftest test-integration-org-capture-popup-display-sole-window () + "Integration: in an \"org-capture\"-named frame, displaying a CAPTURE-* +buffer fills the frame's sole window via the registered display-buffer-alist +entry, instead of splitting. + +Components integrated: +- cj/org-capture--popup-display-condition (real) +- cj/org-capture--display-sole-window (real) +- display-buffer / display-buffer-alist (real) + +Validates the popup frame ends with one window showing the CAPTURE buffer." + (let ((buf (get-buffer-create "CAPTURE-itest"))) + (unwind-protect + (progn + (set-frame-parameter nil 'name "org-capture") + (delete-other-windows) + (display-buffer buf) + (should (= (length (window-list)) 1)) + (should (eq (window-buffer (selected-window)) buf))) + (set-frame-parameter nil 'name nil) + (when (buffer-live-p buf) (kill-buffer buf))))) + +;;; cj/--quick-capture-template (single Task into the inbox) + +(ert-deftest test-org-capture-config-quick-capture-template () + "Normal: the quick-capture template is a single Task into INBOX's Inbox." + (let* ((tmpl (cj/--quick-capture-template "/inbox.org")) + (task (assoc "t" tmpl))) + (should (equal (mapcar #'car tmpl) '("t"))) + (should (equal (nth 1 task) "Task")) + (should (eq (nth 2 task) 'entry)) + (should (equal (nth 3 task) '(file+headline "/inbox.org" "Inbox"))) + (should (equal (nth 4 task) "* TODO %?")) + (should (memq :prepend task)))) + +;;; cj/quick-capture (single Task; stubbed org-capture) + +(ert-deftest test-integration-org-capture-quick-capture-binds-task-only () + "Integration: cj/quick-capture runs org-capture with a single Task template +targeting the inbox, dispatched by key. + +Components integrated: +- cj/quick-capture (real) +- cj/--quick-capture-template (real) +- org-capture (MOCKED — records the bound templates and dispatch key)" + (let (captured key) + (cl-letf (((symbol-function 'org-capture) + (lambda (&optional _goto k) (setq captured org-capture-templates key k)))) + (cj/quick-capture)) + (should (equal (mapcar #'car captured) '("t"))) + (should (equal (nth 3 (assoc "t" captured)) (list 'file+headline inbox-file "Inbox"))) + (should (equal (nth 4 (assoc "t" captured)) "* TODO %?")) + (should (equal key "t")))) + +(ert-deftest test-integration-org-capture-quick-capture-closes-frame-on-abort () + "Integration: when capture aborts (org-capture signals), cj/quick-capture +deletes the popup frame instead of leaving it orphaned. + +Components integrated: +- cj/quick-capture (real) +- org-capture (MOCKED — signals user-error \"Abort\") +- cj/org-capture--delete-popup-frame (MOCKED — records the call)" + (let ((deleted 0)) + (cl-letf (((symbol-function 'org-capture) + (lambda (&rest _) (user-error "Abort"))) + ((symbol-function 'cj/org-capture--delete-popup-frame) + (lambda () (cl-incf deleted)))) + (cj/quick-capture)) + (should (= deleted 1)))) + +(ert-deftest test-integration-org-capture-quick-capture-closes-frame-on-quit () + "Integration: a C-g (quit) during capture also closes the popup frame." + (let ((deleted 0)) + (cl-letf (((symbol-function 'org-capture) + (lambda (&rest _) (signal 'quit nil))) + ((symbol-function 'cj/org-capture--delete-popup-frame) + (lambda () (cl-incf deleted)))) + (cj/quick-capture)) + (should (= deleted 1)))) + +(ert-deftest test-integration-org-capture-quick-capture-keeps-frame-on-success () + "Integration: a successful capture (no signal) does NOT delete the frame — +the finalize hook owns that." + (let ((deleted 0)) + (cl-letf (((symbol-function 'org-capture) (lambda (&rest _) nil)) + ((symbol-function 'cj/org-capture--delete-popup-frame) + (lambda () (cl-incf deleted)))) + (cj/quick-capture)) + (should (= deleted 0)))) + +;;; cj/org-capture--popup-frame-p + +(ert-deftest test-org-capture-config-popup-frame-p () + "Normal/Boundary: true only when the selected frame is named \"org-capture\"." + (cl-letf (((symbol-function 'frame-parameter) (lambda (&rest _) "org-capture"))) + (should (cj/org-capture--popup-frame-p))) + (cl-letf (((symbol-function 'frame-parameter) (lambda (&rest _) "emacs"))) + (should-not (cj/org-capture--popup-frame-p)))) + +;;; cj/org-capture--popup-frame (find the popup frame by name) + +(ert-deftest test-org-capture-config-popup-frame-found () + "Normal: returns the live frame whose name is \"org-capture\"." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fb fc))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) + (lambda (f _p) (if (eq f 'fb) "org-capture" "other")))) + (should (eq (cj/org-capture--popup-frame) 'fb)))) + +(ert-deftest test-org-capture-config-popup-frame-none () + "Boundary: no popup frame present yields nil." + (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fc))) + ((symbol-function 'frame-live-p) (lambda (_f) t)) + ((symbol-function 'frame-parameter) (lambda (_f _p) "other"))) + (should-not (cj/org-capture--popup-frame)))) + +;;; cj/quick-capture targets the popup frame + +(ert-deftest test-integration-org-capture-quick-capture-selects-named-frame () + "Integration: cj/quick-capture selects the \"org-capture\" frame found by name, +not whatever frame happens to be selected (the emacsclient -c focus race)." + (let ((focused nil)) + (cl-letf (((symbol-function 'cj/org-capture--popup-frame) (lambda () 'popup-frame)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f))) + ((symbol-function 'org-capture) (lambda (&rest _) nil))) + (cj/quick-capture)) + (should (eq focused 'popup-frame)))) + +(ert-deftest test-integration-org-capture-quick-capture-no-frame-still-captures () + "Integration: when no popup frame is found, cj/quick-capture skips the focus +call and still runs the capture (no error)." + (let ((focused 'unset) + (captured nil)) + (cl-letf (((symbol-function 'cj/org-capture--popup-frame) (lambda () nil)) + ((symbol-function 'select-frame-set-input-focus) + (lambda (f &rest _) (setq focused f))) + ((symbol-function 'org-capture) (lambda (&rest _) (setq captured t)))) + (cj/quick-capture)) + (should (eq focused 'unset)) + (should captured))) + +(provide 'test-org-capture-config-popup-window) +;;; test-org-capture-config-popup-window.el ends here diff --git a/tests/test-org-config-keymap-ownership.el b/tests/test-org-config-keymap-ownership.el index 729d497cb..81f1ccd46 100644 --- a/tests/test-org-config-keymap-ownership.el +++ b/tests/test-org-config-keymap-ownership.el @@ -60,14 +60,14 @@ at the top level." "Sparse-tree commands sit directly under `C-; O' (flat). Lowercase creates, capital of the same letter cancels: `s' / `S' for match-sparse-tree, `t' / `T' for show-todo-tree. Both -capitals resolve to `org-show-all' -- the user's mental model is +capitals resolve to `org-fold-show-all' -- the user's mental model is \"capital cancels the lowercase I just ran\" without having to remember which letter the cancel actually lives on. `R' is `org-reveal' (no lowercase pair -- `r' is the table-row sub-prefix)." (should (eq (keymap-lookup cj/org-map "s") #'org-match-sparse-tree)) - (should (eq (keymap-lookup cj/org-map "S") #'org-show-all)) + (should (eq (keymap-lookup cj/org-map "S") #'org-fold-show-all)) (should (eq (keymap-lookup cj/org-map "t") #'org-show-todo-tree)) - (should (eq (keymap-lookup cj/org-map "T") #'org-show-all)) + (should (eq (keymap-lookup cj/org-map "T") #'org-fold-show-all)) (should (eq (keymap-lookup cj/org-map "R") #'org-reveal))) (ert-deftest test-org-config-keymap-ownership-regression-no-duplicate-org-keymap () diff --git a/tests/test-org-config-table-header.el b/tests/test-org-config-table-header.el new file mode 100644 index 000000000..38e73b483 --- /dev/null +++ b/tests/test-org-config-table-header.el @@ -0,0 +1,115 @@ +;;; test-org-config-table-header.el --- In-buffer org table header fontify -*- lexical-binding: t; -*- + +;;; Commentary: +;; Org has no in-buffer header-row face -- the whole table uses `org-table'. +;; cj/--org-table-header-row-p, cj/--org-table-first-hline-position, and the +;; font-lock matcher cj/--org-fontify-table-header-matcher (org-config.el) add +;; one: they identify a table's header rows (the non-hline rows above its first +;; hline) so font-lock can prepend `org-table-header' there. These exercise the +;; detection logic directly against fixture tables, matching the tag-alignment +;; test's pure-logic style. + +;;; Code: + +(require 'ert) +(require 'org) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-config) + +(defmacro test-org-th--in (content &rest body) + "Run BODY in a temp org buffer holding CONTENT, hooks suppressed." + (declare (indent 1)) + `(let ((org-mode-hook nil)) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +(defun test-org-th--goto (substring) + "Move point to the beginning of the line containing SUBSTRING." + (goto-char (point-min)) + (search-forward substring) + (beginning-of-line)) + +;; ----- cj/--org-table-header-row-p ----- + +(ert-deftest test-org-table-header-row-p-header-above-hline () + "Normal: a non-hline row above the first hline is a header row." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "Name") + (should (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-body-row-not-header () + "Normal: a row below the first hline is not a header row." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "Bob") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-hline-not-header () + "Boundary: the hline itself is not a header row." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "----") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-no-hline-no-header () + "Boundary: a table with no hline has no header rows." + (test-org-th--in "| A | B |\n| x | y |\n" + (test-org-th--goto "A |") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-multi-row-header () + "Boundary: every non-hline row above the first hline is a header row." + (test-org-th--in "| A | B |\n| C | D |\n|---+---|\n| x | y |\n" + (test-org-th--goto "A |") + (should (cj/--org-table-header-row-p)) + (test-org-th--goto "C |") + (should (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-key-value-first-row-only () + "Boundary: hline-after-every-row table -- only the first row is header." + (test-org-th--in "| Status | draft |\n|--------+-------|\n| Owner | cj |\n|--------+-------|\n" + (test-org-th--goto "Status") + (should (cj/--org-table-header-row-p)) + (test-org-th--goto "Owner") + (should-not (cj/--org-table-header-row-p)))) + +(ert-deftest test-org-table-header-row-p-non-table-line () + "Error: a line that is not in a table is never a header row." + (test-org-th--in "Just some prose.\n" + (test-org-th--goto "prose") + (should-not (cj/--org-table-header-row-p)))) + +;; ----- cj/--org-table-first-hline-position ----- + +(ert-deftest test-org-table-first-hline-position-found () + "Normal: returns the bol of the first hline in the table." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (test-org-th--goto "Name") + (let ((expected (save-excursion (goto-char (point-min)) + (forward-line 1) + (line-beginning-position)))) + (should (equal (cj/--org-table-first-hline-position) expected))))) + +(ert-deftest test-org-table-first-hline-position-none () + "Boundary: a table with no hline returns nil." + (test-org-th--in "| A | B |\n| x | y |\n" + (test-org-th--goto "A |") + (should-not (cj/--org-table-first-hline-position)))) + +;; ----- cj/--org-fontify-table-header-matcher ----- + +(ert-deftest test-org-fontify-table-header-matcher-matches-header-only () + "Normal: the matcher sets match data to the header row, then stops." + (test-org-th--in "| Name | Age |\n|------+-----|\n| Bob | 3 |\n" + (should (cj/--org-fontify-table-header-matcher (point-max))) + (should (equal (match-string 0) "| Name | Age |")) + (should-not (cj/--org-fontify-table-header-matcher (point-max))))) + +(ert-deftest test-org-fontify-table-header-matcher-no-header () + "Boundary: a table with no hline yields no matches." + (test-org-th--in "| A | B |\n| x | y |\n" + (should-not (cj/--org-fontify-table-header-matcher (point-max))))) + +(provide 'test-org-config-table-header) +;;; test-org-config-table-header.el ends here diff --git a/tests/test-org-drill-config-commands.el b/tests/test-org-drill-config-commands.el index 7d1976164..38f6b66e3 100644 --- a/tests/test-org-drill-config-commands.el +++ b/tests/test-org-drill-config-commands.el @@ -38,7 +38,7 @@ (let (opened (drilled 0)) (cl-letf (((symbol-function 'cj/--drill-pick-file) (lambda (_dir) "/decks/german.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'org-drill) (lambda (&rest _) (cl-incf drilled)))) (cj/drill-edit)) @@ -54,7 +54,7 @@ (with-temp-file (expand-file-name "latin.org" tmp)) (cl-letf (((symbol-function 'read-directory-name) (lambda (&rest _) tmp)) ((symbol-function 'completing-read) (lambda (&rest _) "latin.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f)))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f)))) (cj/drill-edit t)) (should (equal (expand-file-name "latin.org" tmp) opened))) (delete-directory tmp t)))) @@ -71,21 +71,50 @@ ;;; cj/drill-refile -(ert-deftest test-org-drill-refile-sets-targets-and-delegates () - "Normal: drill-refile narrows `org-refile-targets' to current buffer + -`drill-dir', then dispatches to `org-refile' via `call-interactively'." - (let (seen-targets called-fn) - (cl-letf (((symbol-function 'call-interactively) - (lambda (fn) +(ert-deftest test-org-drill-refile-targets-from-validated-helper () + "Normal: drill-refile builds its drill targets from the shared +`cj/--drill-files-or-error' helper, expanded against `drill-dir' — not from +a raw `directory-files' call (so it inherits the helper's dot-file exclusion +and validation)." + (let ((drill-dir "/tmp/cj-drill/") + seen-targets called-fn) + (cl-letf (((symbol-function 'cj/--drill-files-or-error) + (lambda (_dir) '("a.org" "b.org"))) + ;; If the old raw path were still in use it would call + ;; `directory-files'; a sentinel here keeps it from masquerading. + ((symbol-function 'directory-files) + (lambda (&rest _) '("/WRONG/raw.org"))) + ((symbol-function 'call-interactively) + (lambda (fn &rest _) (setq called-fn fn seen-targets org-refile-targets)))) (cj/drill-refile)) (should (eq called-fn 'org-refile)) - (should seen-targets) - ;; Two entries: (nil :maxlevel . 1) and (drill-dir :maxlevel . 1). (should (= 2 (length seen-targets))) (should (assoc nil seen-targets)) - (should (assoc 'drill-dir seen-targets)))) + (should (equal (car (nth 1 seen-targets)) + '("/tmp/cj-drill/a.org" "/tmp/cj-drill/b.org"))))) + +(ert-deftest test-org-drill-refile-does-not-clobber-global-targets () + "Error: drill-refile let-binds `org-refile-targets'; the session-wide value +survives the call instead of being permanently replaced." + (let ((drill-dir "/tmp/cj-drill/") + (org-refile-targets '((sentinel :maxlevel . 9)))) + (cl-letf (((symbol-function 'cj/--drill-files-or-error) (lambda (_dir) '("a.org"))) + ((symbol-function 'call-interactively) (lambda (_fn &rest _) nil))) + (cj/drill-refile)) + (should (equal org-refile-targets '((sentinel :maxlevel . 9)))))) + +(ert-deftest test-org-drill-refile-errors-on-missing-drill-dir () + "Error: a missing or unreadable drill dir signals a clear `user-error' via +the shared validated helper, instead of a low-level error, and never reaches +`org-refile'." + (let ((drill-dir (expand-file-name "cj-drill-nonexistent-XYZ/" + temporary-file-directory)) + (called nil)) + (cl-letf (((symbol-function 'call-interactively) (lambda (_fn &rest _) (setq called t)))) + (should-error (cj/drill-refile) :type 'user-error)) + (should-not called))) (provide 'test-org-drill-config-commands) ;;; test-org-drill-config-commands.el ends here diff --git a/tests/test-org-drill-config.el b/tests/test-org-drill-config.el index d3057de2a..9dffa0bca 100644 --- a/tests/test-org-drill-config.el +++ b/tests/test-org-drill-config.el @@ -118,7 +118,7 @@ (let (opened (drilled 0)) (cl-letf (((symbol-function 'cj/--drill-pick-file) (lambda (_dir) "/decks/french.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'org-drill) (lambda (&rest _) (cl-incf drilled)))) (cj/drill-start)) (should (equal "/decks/french.org" opened)) @@ -131,7 +131,7 @@ (let (opened) (cl-letf (((symbol-function 'read-directory-name) (lambda (&rest _) dir)) ((symbol-function 'completing-read) (lambda (&rest _) "latin.org")) - ((symbol-function 'find-file) (lambda (f) (setq opened f))) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f))) ((symbol-function 'org-drill) #'ignore)) (cj/drill-start t)) (should (equal (expand-file-name "latin.org" dir) opened))))) diff --git a/tests/test-org-faces-config.el b/tests/test-org-faces-config.el new file mode 100644 index 000000000..8e7da3309 --- /dev/null +++ b/tests/test-org-faces-config.el @@ -0,0 +1,54 @@ +;;; test-org-faces-config.el --- Tests for org-faces-config -*- lexical-binding: t; -*- + +;;; Commentary: +;; Verifies the custom agenda header-row faces exist and that the keyword and +;; priority maps wire each keyword / priority to its org-faces-* face. org is +;; required first so the `with-eval-after-load' wiring in org-faces-config fires +;; on load. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-faces-config) + +(ert-deftest test-org-faces-config-base-faces-exist () + "Normal: every base keyword and priority face is defined." + (dolist (f '(org-faces-todo org-faces-project org-faces-doing org-faces-waiting + org-faces-verify org-faces-stalled org-faces-delegated org-faces-failed + org-faces-done org-faces-cancelled + org-faces-priority-a org-faces-priority-b org-faces-priority-c org-faces-priority-d)) + (should (facep f)))) + +(ert-deftest test-org-faces-config-dim-faces-exist () + "Normal: every dim variant is defined (auto-dim remaps onto these)." + (dolist (f '(org-faces-todo-dim org-faces-project-dim org-faces-doing-dim org-faces-waiting-dim + org-faces-verify-dim org-faces-stalled-dim org-faces-delegated-dim org-faces-failed-dim + org-faces-done-dim org-faces-cancelled-dim + org-faces-priority-a-dim org-faces-priority-b-dim org-faces-priority-c-dim org-faces-priority-d-dim)) + (should (facep f)))) + +(ert-deftest test-org-faces-config-keyword-map () + "Normal: representative keywords map to their org-faces-* face." + (should (eq (cdr (assoc "TODO" org-todo-keyword-faces)) 'org-faces-todo)) + (should (eq (cdr (assoc "VERIFY" org-todo-keyword-faces)) 'org-faces-verify)) + (should (eq (cdr (assoc "CANCELLED" org-todo-keyword-faces)) 'org-faces-cancelled)) + (should (eq (cdr (assoc "DELEGATED" org-todo-keyword-faces)) 'org-faces-delegated))) + +(ert-deftest test-org-faces-config-keyword-coverage () + "Boundary: all ten keywords are mapped, each to a real face." + (dolist (kw '("TODO" "PROJECT" "DOING" "WAITING" "VERIFY" "STALLED" + "DELEGATED" "FAILED" "DONE" "CANCELLED")) + (let ((face (cdr (assoc kw org-todo-keyword-faces)))) + (should face) + (should (facep face))))) + +(ert-deftest test-org-faces-config-priority-map () + "Normal: each priority A-D maps to its org-faces-priority-* face." + (should (eq (cdr (assq ?A org-priority-faces)) 'org-faces-priority-a)) + (should (eq (cdr (assq ?B org-priority-faces)) 'org-faces-priority-b)) + (should (eq (cdr (assq ?C org-priority-faces)) 'org-faces-priority-c)) + (should (eq (cdr (assq ?D org-priority-faces)) 'org-faces-priority-d))) + +(provide 'test-org-faces-config) +;;; test-org-faces-config.el ends here diff --git a/tests/test-org-noter-config-commands.el b/tests/test-org-noter-config-commands.el index 8860af06e..70c78645c 100644 --- a/tests/test-org-noter-config-commands.el +++ b/tests/test-org-noter-config-commands.el @@ -115,7 +115,7 @@ ((symbol-function 'org-id-uuid) (lambda () "00000000-0000-0000-0000-000000000000")) ((symbol-function 'find-file-noselect) - (lambda (f) (get-buffer-create (concat "*test-" f "*"))))) + (lambda (f &rest _) (get-buffer-create (concat "*test-" f "*"))))) (let ((path (cj/org-noter--create-notes-file))) (should (file-exists-p path)) (with-temp-buffer @@ -186,7 +186,7 @@ ((symbol-function 'org-noter--get-doc-window) (lambda () 'doc-win)) ((symbol-function 'select-window) - (lambda (w) (setq selected w)))) + (lambda (w &rest _) (setq selected w)))) (cj/org-noter-start)) (should (eq selected 'doc-win)))) @@ -232,7 +232,7 @@ ((symbol-function 'org-noter--get-doc-window) (lambda () 'doc-win)) ((symbol-function 'select-window) - (lambda (w) (setq selected w))) + (lambda (w &rest _) (setq selected w))) ((symbol-function 'org-noter-insert-note) (lambda () (setq inserted t)))) (cj/org-noter-insert-note-dwim)) diff --git a/tests/test-org-refile-config-commands.el b/tests/test-org-refile-config-commands.el index 9bdd33647..2e99e9152 100644 --- a/tests/test-org-refile-config-commands.el +++ b/tests/test-org-refile-config-commands.el @@ -54,7 +54,7 @@ (with-temp-buffer (setq buffer-file-name "/tmp/notes.org") (cl-letf (((symbol-function 'call-interactively) - (lambda (_fn) + (lambda (_fn &rest _) (setq seen-targets org-refile-targets))) ((symbol-function 'save-buffer) #'ignore)) (cj/org-refile-in-file)) @@ -73,7 +73,7 @@ (setq buffer-file-name "/tmp/notes.org") (cl-letf (((symbol-function 'call-interactively) #'ignore) ((symbol-function 'save-buffer) - (lambda () (setq saved t)))) + (lambda (&rest _) (setq saved t)))) (cj/org-refile-in-file)) (setq buffer-file-name nil)) (should saved))) diff --git a/tests/test-org-refile-config-scan-targets.el b/tests/test-org-refile-config-scan-targets.el index 71451a29a..6123d3262 100644 --- a/tests/test-org-refile-config-scan-targets.el +++ b/tests/test-org-refile-config-scan-targets.el @@ -101,9 +101,10 @@ maxlevel rules when no roam tags and no code/projects todo files exist." (should (= 1 hits))) (delete-directory tmp t)))) -(ert-deftest test-org-refile-scan-targets-includes-roam-project-and-topic-files () - "Normal: when the roam helpers are available, Project and Topic files -become additional refile targets." +(ert-deftest test-org-refile-scan-targets-includes-roam-topic-not-project () + "Normal: roam Topic files become refile targets; Project files do NOT. +Project notes were dropped as refile targets (2026-06-24) -- roam Projects are +no longer scanned for refile." (let* ((tmp (file-name-as-directory (make-temp-file "cj-refile-roam-" t))) (inbox-file "/tmp/test-inbox.org") (reference-file "/tmp/test-reference.org") @@ -121,8 +122,8 @@ become additional refile targets." (lambda () nil))) (let* ((result (cj/--org-refile-scan-targets)) (paths (mapcar #'car result))) - (should (member "/notes/alpha.org" paths)) - (should (member "/notes/topic.org" paths)))) + (should (member "/notes/topic.org" paths)) + (should-not (member "/notes/alpha.org" paths)))) (delete-directory tmp t)))) (ert-deftest test-org-refile-scan-targets-survives-permission-denied () diff --git a/tests/test-org-reveal-config-header-template.el b/tests/test-org-reveal-config-header-template.el index df1db9e77..9bda10db7 100644 --- a/tests/test-org-reveal-config-header-template.el +++ b/tests/test-org-reveal-config-header-template.el @@ -24,9 +24,9 @@ ;; Helper to call template with deterministic date and author (defun test-reveal--header (title) "Call cj/--reveal-header-template with TITLE, mocking time and user." - (cl-letf (((symbol-function 'user-full-name) (lambda () "Test Author")) + (cl-letf (((symbol-function 'user-full-name) (lambda (&rest _) "Test Author")) ((symbol-function 'format-time-string) - (lambda (_fmt) "2026-02-14"))) + (lambda (_fmt &rest _) "2026-02-14"))) (cj/--reveal-header-template title))) ;;; Normal Cases diff --git a/tests/test-org-roam-config-dailies-head.el b/tests/test-org-roam-config-dailies-head.el new file mode 100644 index 000000000..631f017c3 --- /dev/null +++ b/tests/test-org-roam-config-dailies-head.el @@ -0,0 +1,29 @@ +;;; test-org-roam-config-dailies-head.el --- Tests for the dailies template head -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/--org-roam-dailies-head' is the head inserted into a new org-roam +;; daily file. #+FILETAGS and #+TITLE must sit on separate lines, or Org +;; never parses the #+TITLE keyword and the FILETAGS value swallows the +;; rest of the line. + +;;; Code: + +(require 'ert) +(require 'testutil-general) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-roam-config) + +(ert-deftest test-org-roam-config-dailies-head-separates-filetags-and-title () + "Boundary: #+FILETAGS and #+TITLE sit on separate lines." + (should (string-match-p "#\\+FILETAGS: Journal\n#\\+TITLE:" + cj/--org-roam-dailies-head)) + ;; And never run together on one line. + (should-not (string-match-p "Journal #\\+TITLE:" cj/--org-roam-dailies-head))) + +(ert-deftest test-org-roam-config-dailies-head-ends-with-newline () + "Boundary: the head ends with a newline so the capture body starts clean." + (should (string-suffix-p "\n" cj/--org-roam-dailies-head))) + +(provide 'test-org-roam-config-dailies-head) +;;; test-org-roam-config-dailies-head.el ends here diff --git a/tests/test-org-webclipper-commands.el b/tests/test-org-webclipper-commands.el index be7fc38cf..fb693192f 100644 --- a/tests/test-org-webclipper-commands.el +++ b/tests/test-org-webclipper-commands.el @@ -120,7 +120,7 @@ that registers the webclip entry. Providing `'org-protocol' fires the block." (let ((cj/--webclip-url "https://example.com") (cj/--webclip-title "Title")) (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (let ((err (should-error (cj/org-protocol-webclip-handler) :type 'user-error))) (should (string-match-p "pandoc" (cadr err))))))) @@ -130,7 +130,7 @@ that registers the webclip entry. Providing `'org-protocol' fires the block." (let ((cj/--webclip-url "https://example.com") (cj/--webclip-title "Title")) (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'executable-find) (lambda (_) "/usr/bin/pandoc")) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/pandoc")) ((symbol-function 'org-web-tools--url-as-readable-org) (lambda (_) "* Page Title\n** Sub heading\nBody.\n")) ((symbol-function 'message) #'ignore)) @@ -142,7 +142,7 @@ that registers the webclip entry. Providing `'org-protocol' fires the block." (let ((cj/--webclip-url "https://example.com") (cj/--webclip-title "Title")) (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) - ((symbol-function 'executable-find) (lambda (_) "/usr/bin/pandoc")) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/pandoc")) ((symbol-function 'org-web-tools--url-as-readable-org) (lambda (_) "* Page Title\n** Sub heading\nBody.\n")) ((symbol-function 'message) #'ignore)) diff --git a/tests/test-prog-c-mode-settings.el b/tests/test-prog-c-mode-settings.el index eef2d9102..33c503377 100644 --- a/tests/test-prog-c-mode-settings.el +++ b/tests/test-prog-c-mode-settings.el @@ -16,9 +16,9 @@ "Normal: cj/c-mode-settings applies the documented buffer-local values." (with-temp-buffer (cl-letf (((symbol-function 'auto-fill-mode) (lambda (&rest _) nil)) - ((symbol-function 'electric-pair-mode) (lambda (&rest _) nil)) + ((symbol-function 'electric-pair-local-mode) (lambda (&rest _) nil)) ((symbol-function 'lsp-deferred) (lambda (&rest _) nil)) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/c-mode-settings)) (should (eq indent-tabs-mode nil)) (should (= c-basic-offset 4)) @@ -31,9 +31,9 @@ (let ((lsp-calls 0)) (with-temp-buffer (cl-letf (((symbol-function 'auto-fill-mode) (lambda (&rest _) nil)) - ((symbol-function 'electric-pair-mode) (lambda (&rest _) nil)) + ((symbol-function 'electric-pair-local-mode) (lambda (&rest _) nil)) ((symbol-function 'lsp-deferred) (lambda () (cl-incf lsp-calls))) - ((symbol-function 'executable-find) (lambda (_) "/usr/bin/clangd"))) + ((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/clangd"))) (cj/c-mode-settings))) (should (= lsp-calls 1)))) @@ -42,9 +42,9 @@ (let ((lsp-calls 0)) (with-temp-buffer (cl-letf (((symbol-function 'auto-fill-mode) (lambda (&rest _) nil)) - ((symbol-function 'electric-pair-mode) (lambda (&rest _) nil)) + ((symbol-function 'electric-pair-local-mode) (lambda (&rest _) nil)) ((symbol-function 'lsp-deferred) (lambda () (cl-incf lsp-calls))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/c-mode-settings))) (should (zerop lsp-calls)))) diff --git a/tests/test-prog-general--deadgrep.el b/tests/test-prog-general--deadgrep.el new file mode 100644 index 000000000..21223105d --- /dev/null +++ b/tests/test-prog-general--deadgrep.el @@ -0,0 +1,44 @@ +;;; test-prog-general--deadgrep.el --- Tests for the deadgrep helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/deadgrep--initial-term (region text or symbol at point) and cj/--deadgrep-run +;; (the normalize-root + read-term + invoke tail shared by cj/deadgrep-here and +;; cj/deadgrep-in-dir) were lifted out of the deadgrep use-package :config. +;; deadgrep is mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +(ert-deftest test-prg-deadgrep-initial-term-symbol-at-point () + "Normal: with no region, the symbol at point seeds the search." + (with-temp-buffer + (insert "hello world") + (goto-char (point-min)) + (should (equal (cj/deadgrep--initial-term) "hello")))) + +(ert-deftest test-prg-deadgrep-initial-term-region () + "Normal: an active region's text seeds the search." + (with-temp-buffer + (insert "needle") + (transient-mark-mode 1) + (set-mark (point-min)) + (goto-char (point-max)) + (activate-mark) + (should (equal (cj/deadgrep--initial-term) "needle")))) + +(ert-deftest test-prg-deadgrep-run-normalizes-root-and-passes-term () + "Normal: ROOT is normalized to a directory and TERM is passed through." + (let (got-term got-root) + (cl-letf (((symbol-function 'deadgrep) + (lambda (term root) (setq got-term term got-root root)))) + (cj/--deadgrep-run "/tmp/foo" "needle")) + (should (equal got-term "needle")) + (should (equal got-root "/tmp/foo/")))) + +(provide 'test-prog-general--deadgrep) +;;; test-prog-general--deadgrep.el ends here diff --git a/tests/test-prog-general--electric-pair-angle.el b/tests/test-prog-general--electric-pair-angle.el new file mode 100644 index 000000000..cb33725a2 --- /dev/null +++ b/tests/test-prog-general--electric-pair-angle.el @@ -0,0 +1,54 @@ +;;; test-prog-general--electric-pair-angle.el --- Angle-bracket pairing inhibit -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for cj/--electric-pair-inhibit-angle, which stops electric-pair from +;; pairing "<" into "<>". Craig's yasnippet keys start with "<" (e.g. <cj); +;; auto-pairing the "<" strands a ">" after the expanded snippet, which broke +;; the cj-comment close fence into "#+end_src>". + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'elec-pair) +(require 'org) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +;;; cj/--electric-pair-inhibit-angle + +(ert-deftest test-prog-general-electric-pair-inhibit-angle-open () + "Normal: the open angle bracket is inhibited." + (should (cj/--electric-pair-inhibit-angle ?<))) + +(ert-deftest test-prog-general-electric-pair-inhibit-angle-delegates () + "Boundary: any other character defers to electric-pair-default-inhibit." + (cl-letf (((symbol-function 'electric-pair-default-inhibit) + (lambda (_c) 'delegated))) + (should (eq (cj/--electric-pair-inhibit-angle ?a) 'delegated)) + (should (eq (cj/--electric-pair-inhibit-angle ?\() 'delegated)))) + +(ert-deftest test-prog-general-electric-pair-predicate-installed () + "Normal: prog-general installs the predicate as the global value." + (should (eq electric-pair-inhibit-predicate #'cj/--electric-pair-inhibit-angle))) + +;;; Integration — the actual pairing behavior + +(ert-deftest test-integration-prog-general-angle-not-paired-in-org () + "Integration: in an org buffer (where < has paren syntax), typing < with the +inhibit predicate active inserts just <, not <>. + +Components integrated: +- cj/--electric-pair-inhibit-angle (real) +- electric-pair-local-mode / self-insert-command (real) +- org-mode syntax table (real — gives < paren syntax)" + (with-temp-buffer + (org-mode) + (electric-pair-local-mode 1) + (setq-local electric-pair-inhibit-predicate #'cj/--electric-pair-inhibit-angle) + (let ((last-command-event ?<)) + (call-interactively #'self-insert-command)) + (should (equal (buffer-substring-no-properties (point-min) (point-max)) "<")))) + +(provide 'test-prog-general--electric-pair-angle) +;;; test-prog-general--electric-pair-angle.el ends here diff --git a/tests/test-prog-general--find-file-respecting-split.el b/tests/test-prog-general--find-file-respecting-split.el index 6d45c51c0..821cc79d6 100644 --- a/tests/test-prog-general--find-file-respecting-split.el +++ b/tests/test-prog-general--find-file-respecting-split.el @@ -23,9 +23,9 @@ (delete-other-windows) (let (current-arg other-called) (cl-letf (((symbol-function 'find-file) - (lambda (f) (setq current-arg f))) + (lambda (f &rest _) (setq current-arg f))) ((symbol-function 'find-file-other-window) - (lambda (_f) (setq other-called t)))) + (lambda (_f &rest _) (setq other-called t)))) (cj/--find-file-respecting-split "/tmp/proj/todo.org")) (should (equal current-arg "/tmp/proj/todo.org")) (should-not other-called)))) @@ -37,9 +37,9 @@ (split-window-right) (let (other-arg current-called) (cl-letf (((symbol-function 'find-file-other-window) - (lambda (f) (setq other-arg f))) + (lambda (f &rest _) (setq other-arg f))) ((symbol-function 'find-file) - (lambda (_f) (setq current-called t)))) + (lambda (_f &rest _) (setq current-called t)))) (cj/--find-file-respecting-split "/tmp/proj/todo.org")) (should (equal other-arg "/tmp/proj/todo.org")) (should-not current-called)))) @@ -52,9 +52,9 @@ (split-window-below) (let (other-called current-called) (cl-letf (((symbol-function 'find-file-other-window) - (lambda (_f) (setq other-called t))) + (lambda (_f &rest _) (setq other-called t))) ((symbol-function 'find-file) - (lambda (_f) (setq current-called t)))) + (lambda (_f &rest _) (setq current-called t)))) (cj/--find-file-respecting-split "/tmp/proj/todo.org")) (should other-called) (should-not current-called)))) diff --git a/tests/test-prog-general--find-project-root-file.el b/tests/test-prog-general--find-project-root-file.el new file mode 100644 index 000000000..97db0b979 --- /dev/null +++ b/tests/test-prog-general--find-project-root-file.el @@ -0,0 +1,49 @@ +;;; test-prog-general--find-project-root-file.el --- Tests for cj/find-project-root-file -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/find-project-root-file returns the first file in the current Projectile +;; project root matching a regexp (string or rx form), case-insensitively. It +;; was defined inside the projectile use-package :config (unreachable under +;; `make test'); lifting it to top level makes it unit-testable. projectile's +;; root and directory-files are mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'seq) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +(defmacro test-prg--with-root (files &rest body) + "Run BODY with projectile-project-root \"/proj/\" and directory-files = FILES." + (declare (indent 1)) + `(cl-letf (((symbol-function 'projectile-project-root) (lambda (&rest _) "/proj/")) + ((symbol-function 'directory-files) (lambda (&rest _) ,files))) + ,@body)) + +(ert-deftest test-prg-find-root-file-string-regexp () + "Normal: a string regexp matches case-insensitively." + (test-prg--with-root '("README.md" "TODO.org" "src") + (should (equal (cj/find-project-root-file "^todo\\.org$") "TODO.org")))) + +(ert-deftest test-prg-find-root-file-rx-form () + "Normal: an rx form is converted and matched." + (test-prg--with-root '("notes.txt" "todo.md" "x") + (should (equal (cj/find-project-root-file + '(seq bos "todo." (or "org" "md" "txt") eos)) + "todo.md")))) + +(ert-deftest test-prg-find-root-file-no-match () + "Boundary: no matching file yields nil." + (test-prg--with-root '("a.el" "b.el") + (should (null (cj/find-project-root-file "^todo\\.org$"))))) + +(ert-deftest test-prg-find-root-file-no-project () + "Boundary: outside a project (nil root) yields nil." + (cl-letf (((symbol-function 'projectile-project-root) (lambda (&rest _) nil))) + (should (null (cj/find-project-root-file "^todo\\.org$"))))) + +(provide 'test-prog-general--find-project-root-file) +;;; test-prog-general--find-project-root-file.el ends here diff --git a/tests/test-prog-general-open-project-daily-prep.el b/tests/test-prog-general-open-project-daily-prep.el index d9c78ff0e..5bc4d7d27 100644 --- a/tests/test-prog-general-open-project-daily-prep.el +++ b/tests/test-prog-general-open-project-daily-prep.el @@ -40,7 +40,7 @@ (unwind-protect (progn (cl-letf (((symbol-function 'projectile-project-root) (lambda () root)) - ((symbol-function 'find-file-other-window) (lambda (f) (setq opened f)))) + ((symbol-function 'find-file-other-window) (lambda (f &rest _) (setq opened f)))) (setq result (cj/open-project-daily-prep))) (should-not opened) (should (string-match-p "No daily-prep.org" result))) @@ -50,7 +50,7 @@ "Error: outside a Projectile project, do not open; report it." (let (opened result) (cl-letf (((symbol-function 'projectile-project-root) (lambda () nil)) - ((symbol-function 'find-file-other-window) (lambda (f) (setq opened f)))) + ((symbol-function 'find-file-other-window) (lambda (f &rest _) (setq opened f)))) (setq result (cj/open-project-daily-prep))) (should-not opened) (should (string-match-p "Not in a Projectile project" result)))) diff --git a/tests/test-prog-go-commands.el b/tests/test-prog-go-commands.el index 6947f358b..6e6998348 100644 --- a/tests/test-prog-go-commands.el +++ b/tests/test-prog-go-commands.el @@ -27,19 +27,19 @@ "Normal: tab-width 4, standard-indent 4, indent-tabs-mode t (Go convention)." (with-temp-buffer (cl-letf (((symbol-function 'company-mode) #'ignore) - ((symbol-function 'electric-pair-mode) #'ignore)) + ((symbol-function 'electric-pair-local-mode) #'ignore)) (cj/go-setup) (should (= tab-width 4)) (should (= standard-indent 4)) (should indent-tabs-mode)))) (ert-deftest test-prog-go-setup-enables-mode-helpers () - "Normal: company-mode and electric-pair-mode are both called." + "Normal: company-mode and electric-pair-local-mode are both called." (with-temp-buffer (let ((called nil)) (cl-letf (((symbol-function 'company-mode) (lambda (&rest _) (push 'company called))) - ((symbol-function 'electric-pair-mode) + ((symbol-function 'electric-pair-local-mode) (lambda (arg) (push (cons 'pair arg) called)))) (cj/go-setup)) (should (memq 'company called)) @@ -50,11 +50,11 @@ (with-temp-buffer (let ((started nil)) (cl-letf (((symbol-function 'company-mode) #'ignore) - ((symbol-function 'electric-pair-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) - (lambda (path) (when (equal path gopls-path) "/usr/bin/gopls")))) + (lambda (path &rest _) (when (equal path gopls-path) "/usr/bin/gopls")))) (cj/go-setup)) (should started)))) @@ -63,10 +63,10 @@ (with-temp-buffer (let ((started nil)) (cl-letf (((symbol-function 'company-mode) #'ignore) - ((symbol-function 'electric-pair-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/go-setup)) (should-not started)))) @@ -104,7 +104,7 @@ "Normal: with delve on PATH, `gud-gdb' is called with `dlv debug'." (let (started) (cl-letf (((symbol-function 'executable-find) - (lambda (path) (when (equal path dlv-path) "/usr/bin/dlv"))) + (lambda (path &rest _) (when (equal path dlv-path) "/usr/bin/dlv"))) ((symbol-function 'file-executable-p) (lambda (_) nil)) ((symbol-function 'gud-gdb) (lambda (cmd &rest _) (setq started cmd)))) @@ -117,7 +117,7 @@ "Error: delve missing -> message + no gud-gdb call." (let ((started nil) (msg nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil)) ((symbol-function 'file-executable-p) (lambda (_) nil)) ((symbol-function 'gud-gdb) (lambda (&rest _) (setq started t))) diff --git a/tests/test-prog-json--json-format-buffer.el b/tests/test-prog-json--json-format-buffer.el index 70d7e98bb..c6297a404 100644 --- a/tests/test-prog-json--json-format-buffer.el +++ b/tests/test-prog-json--json-format-buffer.el @@ -16,7 +16,7 @@ (ert-deftest test-prog-json--json-format-buffer-invokes-jq-argv () "Normal: with jq present, the formatter calls jq via argv, no shell." (let (program args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/jq")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/jq")) ((symbol-function 'call-process-region) (lambda (_start _end prog &rest rest) (setq program prog @@ -31,7 +31,7 @@ (ert-deftest test-prog-json--json-format-buffer-no-clobber-on-failure () "Error: a non-zero jq exit leaves the buffer untouched and signals an error." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/jq")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/jq")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "jq: parse error")) @@ -112,7 +112,7 @@ (ert-deftest test-prog-json--json-format-buffer-fallback-formats-without-jq () "Falls back to built-in formatter when jq is not found." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (with-temp-buffer (insert "{\"b\":1,\"a\":2}") (cj/json-format-buffer) diff --git a/tests/test-prog-lsp.el b/tests/test-prog-lsp.el new file mode 100644 index 000000000..7e38111d0 --- /dev/null +++ b/tests/test-prog-lsp.el @@ -0,0 +1,66 @@ +;;; 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-commands.el b/tests/test-prog-python-commands.el index 443e7d175..55aa502f7 100644 --- a/tests/test-prog-python-commands.el +++ b/tests/test-prog-python-commands.el @@ -64,7 +64,7 @@ "Normal: with mypy on PATH, `compile' gets the builder's command." (let ((mypy-path "mypy") compiled) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/mypy")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/mypy")) ((symbol-function 'compile) (lambda (cmd &rest _) (setq compiled cmd)))) (with-temp-buffer (setq buffer-file-name "/home/me/foo.py") @@ -76,7 +76,7 @@ "Boundary: no file -> the command targets `default-directory'." (let ((mypy-path "mypy") compiled) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/mypy")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/mypy")) ((symbol-function 'compile) (lambda (cmd &rest _) (setq compiled cmd)))) (with-temp-buffer (setq-local default-directory "/home/me/proj/") @@ -88,7 +88,7 @@ (let ((mypy-path "mypy") (compiled nil) (messaged nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) nil)) ((symbol-function 'compile) (lambda (&rest _) (setq compiled t))) ((symbol-function 'message) (lambda (fmt &rest args) (setq messaged (apply #'format fmt args))))) diff --git a/tests/test-prog-python-setup.el b/tests/test-prog-python-setup.el index 0b56f8cc9..368097c9e 100644 --- a/tests/test-prog-python-setup.el +++ b/tests/test-prog-python-setup.el @@ -71,7 +71,7 @@ electric-pair-local-mode all get called once." ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) - (lambda (path) (when (equal path pyright-path) + (lambda (path &rest _) (when (equal path pyright-path) "/usr/bin/pyright")))) (cj/python-setup)) (should started)))) @@ -86,7 +86,7 @@ electric-pair-local-mode all get called once." ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/python-setup)) (should-not started)))) diff --git a/tests/test-prog-webdev-format.el b/tests/test-prog-webdev-format.el index 694f9e968..cb5da406c 100644 --- a/tests/test-prog-webdev-format.el +++ b/tests/test-prog-webdev-format.el @@ -46,7 +46,7 @@ (ert-deftest test-prog-webdev-format-buffer-runs-prettier-on-the-file () "Normal: with prettier on PATH, the argv targets `buffer-file-name'." (let (program args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end prog &rest rest) ;; rest = (DELETE BUFFER DISPLAY &rest ARGS) @@ -64,7 +64,7 @@ (ert-deftest test-prog-webdev-format-buffer-falls-back-to-file-ts () "Boundary: a buffer with no file uses the \"file.ts\" filename hint." (let (args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog &rest rest) (setq args (nthcdr 3 rest)) @@ -77,7 +77,7 @@ (ert-deftest test-prog-webdev-format-buffer-clamps-point-to-point-max () "Boundary: after a format that shrinks the buffer, point clamps to point-max." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) ;; Simulate prettier writing a shorter result to the output buffer. @@ -91,7 +91,7 @@ (ert-deftest test-prog-webdev-format-buffer-replaces-on-success () "Normal: a zero exit replaces the buffer with the formatter's output." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "const x = 1;\n")) @@ -103,7 +103,7 @@ (ert-deftest test-prog-webdev-format-buffer-no-clobber-on-failure () "Error: a non-zero exit leaves the buffer untouched and signals an error." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "[error] syntax error")) @@ -117,7 +117,7 @@ (ert-deftest test-prog-webdev-format-buffer-errors-without-prettier () "Error: prettier missing -> `user-error', nothing shells out." (let ((ran nil)) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) nil)) ((symbol-function 'call-process-region) (lambda (&rest _) (setq ran t) 0))) (with-temp-buffer diff --git a/tests/test-prog-webdev-setup.el b/tests/test-prog-webdev-setup.el index 45310f237..906a54151 100644 --- a/tests/test-prog-webdev-setup.el +++ b/tests/test-prog-webdev-setup.el @@ -67,7 +67,7 @@ electric-pair-local-mode all get called." ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) ((symbol-function 'executable-find) - (lambda (path) (when (equal path ts-language-server-path) + (lambda (path &rest _) (when (equal path ts-language-server-path) "/usr/bin/typescript-language-server")))) (cj/webdev-setup)) (should started)))) @@ -82,7 +82,7 @@ electric-pair-local-mode all get called." ((symbol-function 'electric-pair-local-mode) #'ignore) ((symbol-function 'lsp-deferred) (lambda (&rest _) (setq started t))) - ((symbol-function 'executable-find) (lambda (_) nil))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (cj/webdev-setup)) (should-not started)))) diff --git a/tests/test-prog-yaml--yaml-format-buffer.el b/tests/test-prog-yaml--yaml-format-buffer.el index 28ad351f9..aae3199ce 100644 --- a/tests/test-prog-yaml--yaml-format-buffer.el +++ b/tests/test-prog-yaml--yaml-format-buffer.el @@ -14,7 +14,7 @@ (ert-deftest test-prog-yaml--yaml-format-buffer-invokes-prettier-argv () "Normal: with prettier present, the formatter calls it via argv, no shell." (let (program args) - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end prog &rest rest) (setq program prog @@ -29,7 +29,7 @@ (ert-deftest test-prog-yaml--yaml-format-buffer-no-clobber-on-failure () "Error: a non-zero prettier exit leaves the buffer untouched and errors." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/prettier")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/prettier")) ((symbol-function 'call-process-region) (lambda (_start _end _prog _delete buffer &rest _) (with-current-buffer buffer (insert "[error] bad yaml")) @@ -98,7 +98,7 @@ (ert-deftest test-prog-yaml--yaml-format-buffer-error-no-prettier () "Signals user-error when prettier is not found." - (cl-letf (((symbol-function 'executable-find) (lambda (_) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (with-temp-buffer (insert "key: value\n") (should-error (cj/yaml-format-buffer) :type 'user-error)))) diff --git a/tests/test-reconcile--dirty-p.el b/tests/test-reconcile--dirty-p.el new file mode 100644 index 000000000..a4c372b66 --- /dev/null +++ b/tests/test-reconcile--dirty-p.el @@ -0,0 +1,49 @@ +;;; test-reconcile--dirty-p.el --- Tests for cj/reconcile--dirty-p -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `cj/reconcile--dirty-p' in reconcile-open-repos.el. It runs +;; git status --porcelain via `cj/reconcile--git' and reports clean (nil), +;; dirty (non-nil), or 'status-failed when git itself errors. The git call +;; is stubbed at the `cj/reconcile--git' boundary (it returns a plist). + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'reconcile-open-repos) + +(defmacro test-reconcile-dirty--with-git (plist &rest body) + "Run BODY with `cj/reconcile--git' stubbed to return PLIST." + (declare (indent 1)) + `(cl-letf (((symbol-function 'cj/reconcile--git) + (lambda (&rest _) ,plist))) + ,@body)) + +;;; Normal Cases + +(ert-deftest test-reconcile-dirty-p-clean-returns-nil () + "Normal: exit 0 with empty porcelain output means clean (nil)." + (test-reconcile-dirty--with-git '(:exit 0 :output "") + (should-not (cj/reconcile--dirty-p "/repo")))) + +(ert-deftest test-reconcile-dirty-p-dirty-returns-non-nil () + "Normal: exit 0 with porcelain content means dirty (non-nil)." + (test-reconcile-dirty--with-git '(:exit 0 :output " M file.el\n") + (should (cj/reconcile--dirty-p "/repo")))) + +;;; Boundary Cases + +(ert-deftest test-reconcile-dirty-p-whitespace-only-is-clean () + "Boundary: whitespace-only output trims to empty and counts as clean." + (test-reconcile-dirty--with-git '(:exit 0 :output " \n") + (should-not (cj/reconcile--dirty-p "/repo")))) + +;;; Error Cases + +(ert-deftest test-reconcile-dirty-p-git-failure-returns-status-failed () + "Error: a non-zero git exit returns the symbol 'status-failed." + (test-reconcile-dirty--with-git '(:exit 128 :output "fatal: not a repo") + (should (eq (cj/reconcile--dirty-p "/repo") 'status-failed)))) + +(provide 'test-reconcile--dirty-p) +;;; test-reconcile--dirty-p.el ends here diff --git a/tests/test-reconcile--find-git-repos.el b/tests/test-reconcile--find-git-repos.el index e065fca90..c6a190a17 100644 --- a/tests/test-reconcile--find-git-repos.el +++ b/tests/test-reconcile--find-git-repos.el @@ -81,6 +81,15 @@ (should (= (length repos) 1)) (should (string-suffix-p "visible-repo" (car repos)))))) +(ert-deftest test-find-git-repos-boundary-dotted-repo-name-found () + "Boundary: a repo whose directory name contains a dot (e.g. mcp.el) is +discovered. Regression for the `^[^.]+$' filter that matched only dot-free +names and silently skipped dotted repos like mcp.el / capture.el." + (reconcile-test-with-temp-dirs + ("mcp.el/.git/" "capture.el/.git/" "plain-repo/.git/") + (let ((repos (cj/find-git-repos test-root))) + (should (= (length repos) 3))))) + (ert-deftest test-find-git-repos-boundary-prunes-heavy-directories () "Skips generated/heavy directories while discovering repos." (reconcile-test-with-temp-dirs diff --git a/tests/test-selection-framework--consult-line-or-repeat.el b/tests/test-selection-framework--consult-line-or-repeat.el index fcaddcfd0..66f5b1724 100644 --- a/tests/test-selection-framework--consult-line-or-repeat.el +++ b/tests/test-selection-framework--consult-line-or-repeat.el @@ -64,5 +64,11 @@ "Normal: `cj/consult-line-or-repeat' is an interactive command." (should (commandp #'cj/consult-line-or-repeat))) +(ert-deftest test-selection-framework-vertico-repeat-save-on-minibuffer-setup () + "Normal: loading the module registers `vertico-repeat-save' on +`minibuffer-setup-hook'. Without it `vertico-repeat' has no saved session +and the second C-s signals \"No Vertico session\"." + (should (memq 'vertico-repeat-save minibuffer-setup-hook))) + (provide 'test-selection-framework--consult-line-or-repeat) ;;; test-selection-framework--consult-line-or-repeat.el ends here diff --git a/tests/test-show-kill-ring--insert-item.el b/tests/test-show-kill-ring--insert-item.el new file mode 100644 index 000000000..a29ca75e6 --- /dev/null +++ b/tests/test-show-kill-ring--insert-item.el @@ -0,0 +1,73 @@ +;;; test-show-kill-ring--insert-item.el --- Tests for show-kill-insert-item -*- lexical-binding: t -*- + +;;; Commentary: +;; Tests for `show-kill-insert-item' in show-kill-ring.el — inserts a +;; kill-ring entry into the current buffer, truncating to +;; `show-kill-max-item-size' with an ellipsis when too long. The ellipsis +;; sits inline for short items and on its own line for items wider than the +;; frame. Frame width is read at runtime so the test is environment-stable. + +;;; Code: + +(require 'ert) +(require 'show-kill-ring) + +;;; Normal Cases + +(ert-deftest test-show-kill-ring-insert-item-short-verbatim () + "Normal: an item shorter than the max is inserted unchanged." + (let ((show-kill-max-item-size 1000)) + (with-temp-buffer + (show-kill-insert-item "hello") + (should (string= (buffer-string) "hello"))))) + +(ert-deftest test-show-kill-ring-insert-item-inline-ellipsis () + "Normal: an over-max item narrower than the frame gets an inline ellipsis." + (let* ((show-kill-max-item-size 5) + (len (/ (frame-width) 2)) ; > max, < (frame-width - 5) + (item (make-string len ?b))) + (with-temp-buffer + (show-kill-insert-item item) + (should (string= (buffer-string) "bbbbb..."))))) + +;;; Boundary Cases + +(ert-deftest test-show-kill-ring-insert-item-length-equals-max-truncates () + "Boundary: length exactly equal to max truncates — the guard is (< len max)." + (let ((show-kill-max-item-size 5)) + (with-temp-buffer + (show-kill-insert-item "hello") ; length 5, equals max + (should (string= (buffer-string) "hello..."))))) + +(ert-deftest test-show-kill-ring-insert-item-wide-newline-ellipsis () + "Boundary: an item wider than the frame puts the ellipsis on its own line." + (let* ((show-kill-max-item-size 5) + (item (make-string (+ (frame-width) 10) ?a))) + (with-temp-buffer + (show-kill-insert-item item) + (should (string= (buffer-string) "aaaaa\n..."))))) + +(ert-deftest test-show-kill-ring-insert-item-max-nil-verbatim () + "Boundary: a non-numeric max disables truncation." + (let ((show-kill-max-item-size nil)) + (with-temp-buffer + (show-kill-insert-item "anything long enough to exceed nothing") + (should (string= (buffer-string) + "anything long enough to exceed nothing"))))) + +(ert-deftest test-show-kill-ring-insert-item-max-negative-verbatim () + "Boundary: a negative max disables truncation." + (let ((show-kill-max-item-size -1)) + (with-temp-buffer + (show-kill-insert-item "abc") + (should (string= (buffer-string) "abc"))))) + +(ert-deftest test-show-kill-ring-insert-item-empty-string () + "Boundary: an empty item inserts nothing and does not error." + (let ((show-kill-max-item-size 1000)) + (with-temp-buffer + (show-kill-insert-item "") + (should (string= (buffer-string) ""))))) + +(provide 'test-show-kill-ring--insert-item) +;;; test-show-kill-ring--insert-item.el ends here diff --git a/tests/test-signal-config-notify.el b/tests/test-signal-config-notify.el new file mode 100644 index 000000000..1a7722893 --- /dev/null +++ b/tests/test-signal-config-notify.el @@ -0,0 +1,150 @@ +;;; 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-signel-notify-function.el b/tests/test-signel-notify-function.el new file mode 100644 index 000000000..e3d97af51 --- /dev/null +++ b/tests/test-signel-notify-function.el @@ -0,0 +1,89 @@ +;;; 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-slack-config-close-all.el b/tests/test-slack-config-close-all.el new file mode 100644 index 000000000..a7f5423b8 --- /dev/null +++ b/tests/test-slack-config-close-all.el @@ -0,0 +1,32 @@ +;;; test-slack-config-close-all.el --- cj/slack-close-all-buffers guard -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/slack-close-all-buffers iterates every buffer. It must not signal +;; void-variable when `slack-current-buffer' has no binding in a buffer (slack +;; not loaded), and must kill only buffers where it is set non-nil. The original +;; read it with `buffer-local-value' (which errors on buffers without the local +;; binding) instead of guarding like its sibling cj/slack-mark-read-and-bury. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'slack-config) + +(ert-deftest test-slack-close-all-buffers-skips-unbound-kills-slack () + "Error/Normal: no signal on buffers without `slack-current-buffer'; only +buffers that have it set non-nil are killed." + (let ((plain (generate-new-buffer " *plain*")) + (slackish (generate-new-buffer " *slackish*"))) + (with-current-buffer slackish (setq-local slack-current-buffer t)) + (unwind-protect + (progn + (cj/slack-close-all-buffers) + (should (buffer-live-p plain)) + (should-not (buffer-live-p slackish))) + (when (buffer-live-p plain) (kill-buffer plain)) + (when (buffer-live-p slackish) (kill-buffer slackish))))) + +(provide 'test-slack-config-close-all) +;;; test-slack-config-close-all.el ends here diff --git a/tests/test-slack-config-commands.el b/tests/test-slack-config-commands.el index 8944662ef..21cbb3e5a 100644 --- a/tests/test-slack-config-commands.el +++ b/tests/test-slack-config-commands.el @@ -194,7 +194,7 @@ ((symbol-function 'slack-buffer-update-mark-request) (lambda (_buf ts) (setq marked ts))) ((symbol-function 'bury-buffer) - (lambda () (setq buried t)))) + (lambda (&rest _) (setq buried t)))) (cj/slack-mark-read-and-bury)) (should (equal marked "1234.5678")) (should buried))) @@ -207,7 +207,7 @@ (cl-letf (((symbol-function 'slack-buffer-update-mark-request) (lambda (&rest _) (setq marked t))) ((symbol-function 'bury-buffer) - (lambda () (setq buried t)))) + (lambda (&rest _) (setq buried t)))) (cj/slack-mark-read-and-bury)) (should-not marked) (should buried))) diff --git a/tests/test-system-commands-resolve-and-run.el b/tests/test-system-commands-resolve-and-run.el index 2c9d98d0c..af2288fd9 100644 --- a/tests/test-system-commands-resolve-and-run.el +++ b/tests/test-system-commands-resolve-and-run.el @@ -118,19 +118,19 @@ does not run the command." (ert-deftest test-system-cmd-service-available-true-on-zero-exit () "Normal: service is available when systemctl exists and `cat' exits 0." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/systemctl")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/systemctl")) ((symbol-function 'call-process) (lambda (&rest _) 0))) (should (cj/system-cmd--emacs-service-available-p)))) (ert-deftest test-system-cmd-service-available-false-on-nonzero-exit () "Boundary: a nonzero exit (no such unit) means not available." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) "/usr/bin/systemctl")) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) "/usr/bin/systemctl")) ((symbol-function 'call-process) (lambda (&rest _) 1))) (should-not (cj/system-cmd--emacs-service-available-p)))) (ert-deftest test-system-cmd-service-available-false-when-systemctl-absent () "Error: with no systemctl on PATH the service can't be available." - (cl-letf (((symbol-function 'executable-find) (lambda (_p) nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (_p &rest _) nil)) ((symbol-function 'call-process) (lambda (&rest _) (error "must not shell out without systemctl")))) (should-not (cj/system-cmd--emacs-service-available-p)))) @@ -220,7 +220,7 @@ kill-emacs directly (the service owns the daemon lifecycle)." (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "Lock Screen")) ((symbol-function 'call-interactively) - (lambda (cmd) (setq called cmd)))) + (lambda (cmd &rest _) (setq called cmd)))) (cj/system-command-menu)) (should (eq called 'cj/system-cmd-lock)))) diff --git a/tests/test-system-defaults-functions.el b/tests/test-system-defaults-functions.el index a5210be01..2562ff6aa 100644 --- a/tests/test-system-defaults-functions.el +++ b/tests/test-system-defaults-functions.el @@ -79,20 +79,6 @@ (should (eq (cj/disabled) nil)) (should (commandp #'cj/disabled))) -;;; cj/minibuffer-setup-hook / cj/minibuffer-exit-hook - -(ert-deftest test-system-defaults-minibuffer-setup-inflates-gc-threshold () - "Normal: entering the minibuffer raises `gc-cons-threshold' to most-positive-fixnum." - (let ((gc-cons-threshold 800000)) - (cj/minibuffer-setup-hook) - (should (= gc-cons-threshold most-positive-fixnum)))) - -(ert-deftest test-system-defaults-minibuffer-exit-restores-gc-threshold () - "Normal: leaving the minibuffer restores `gc-cons-threshold' to 800000." - (let ((gc-cons-threshold most-positive-fixnum)) - (cj/minibuffer-exit-hook) - (should (= gc-cons-threshold 800000)))) - ;;; unpropertize-kill-ring (ert-deftest test-system-defaults-unpropertize-kill-ring-strips-properties () diff --git a/tests/test-system-defaults.el b/tests/test-system-defaults.el index 3c5e59777..f653e1fbb 100644 --- a/tests/test-system-defaults.el +++ b/tests/test-system-defaults.el @@ -24,7 +24,10 @@ "Normal: custom-file points at a throwaway temp file, never the repo. This is what stops accidental Customize writes from landing in tracked init." (test-system-defaults--with-load-environment - (let ((custom-file nil)) + ;; noninteractive is t under ERT batch; bind it nil so the interactive + ;; redirect runs (the module guards the redirect to interactive sessions). + (let ((custom-file nil) + (noninteractive nil)) (test-system-defaults--load) (should (stringp custom-file)) (should (string-prefix-p (file-name-as-directory @@ -35,6 +38,15 @@ This is what stops accidental Customize writes from landing in tracked init." (should-not (string-prefix-p (expand-file-name user-emacs-directory) (expand-file-name custom-file)))))) +(ert-deftest test-system-defaults-custom-file-not-littered-in-batch () + "Boundary: a noninteractive (batch) load does not create a trashbin custom-file. +Guards make validate-modules / byte-compile from dropping a temp file per run." + (test-system-defaults--with-load-environment + (let ((custom-file nil) + (noninteractive t)) + (test-system-defaults--load) + (should-not custom-file)))) + ;;; backup directory (ert-deftest test-system-defaults-backups-redirected-under-user-emacs-dir () @@ -51,19 +63,6 @@ test clears it first to capture the path derived from the sandbox." (expand-file-name dir))) (should (string-suffix-p "backups" (directory-file-name dir))))))) -;;; minibuffer GC hooks - -(ert-deftest test-system-defaults-minibuffer-gc-hooks-registered () - "Normal: the minibuffer GC raise/restore hooks are installed. -Their bodies are tested in test-system-defaults-functions.el; this asserts -they are actually wired onto the minibuffer hooks." - (test-system-defaults--with-load-environment - (let ((minibuffer-setup-hook nil) - (minibuffer-exit-hook nil)) - (test-system-defaults--load) - (should (memq 'cj/minibuffer-setup-hook minibuffer-setup-hook)) - (should (memq 'cj/minibuffer-exit-hook minibuffer-exit-hook))))) - ;;; Customize-save warning (ert-deftest test-system-defaults-customize-save-warns-once () diff --git a/tests/test-system-lib--format-region-with-program.el b/tests/test-system-lib--format-region-with-program.el new file mode 100644 index 000000000..29b392b84 --- /dev/null +++ b/tests/test-system-lib--format-region-with-program.el @@ -0,0 +1,68 @@ +;;; test-system-lib--format-region-with-program.el --- Tests for cj/format-region-with-program -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/format-region-with-program' runs an external formatter over the whole +;; buffer via `call-process-region' (argv, no shell) and replaces the buffer +;; only when the program exits zero. Extracted from the byte-identical +;; per-language helpers in prog-json.el / prog-yaml.el, so this is the first +;; direct unit coverage of the logic. call-process-region is mocked at the +;; boundary (the established pattern in test-prog-json--json-format-buffer.el). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'system-lib) + +(ert-deftest test-system-lib-format-region-with-program-replaces-on-success () + "Normal: on exit 0 the buffer is replaced with the program's output, returns t." + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end _prog &rest rest) + (with-current-buffer (nth 1 rest) (insert "FORMATTED")) + 0))) + (with-temp-buffer + (insert "raw") + (should (eq t (cj/format-region-with-program "fmt"))) + (should (equal "FORMATTED" (buffer-string)))))) + +(ert-deftest test-system-lib-format-region-with-program-forwards-argv () + "Normal: PROGRAM and ARGS reach call-process-region as argv (no shell)." + (let (got-prog got-args) + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end prog &rest rest) + (setq got-prog prog + got-args (nthcdr 3 rest)) + (with-current-buffer (nth 1 rest) (insert "x")) + 0))) + (with-temp-buffer + (cj/format-region-with-program "jq" "--sort-keys" "."))) + (should (equal "jq" got-prog)) + (should (equal '("--sort-keys" ".") got-args)))) + +(ert-deftest test-system-lib-format-region-with-program-empty-output () + "Boundary: empty program output empties the buffer and still returns t." + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end _prog &rest _rest) 0))) ; writes nothing + (with-temp-buffer + (insert "raw") + (should (eq t (cj/format-region-with-program "fmt"))) + (should (equal "" (buffer-string)))))) + +(ert-deftest test-system-lib-format-region-with-program-nonzero-untouched () + "Error: a non-zero exit leaves the buffer untouched and signals user-error +carrying the program's stderr text." + (cl-letf (((symbol-function 'call-process-region) + (lambda (_start _end _prog &rest rest) + (with-current-buffer (nth 1 rest) (insert "boom: bad input")) + 1))) + (with-temp-buffer + (insert "raw") + (let ((err (should-error (cj/format-region-with-program "fmt") + :type 'user-error))) + (should (string-match-p "boom: bad input" (error-message-string err)))) + (should (equal "raw" (buffer-string)))))) + +(provide 'test-system-lib--format-region-with-program) +;;; test-system-lib--format-region-with-program.el ends here diff --git a/tests/test-system-lib-confirm-strong.el b/tests/test-system-lib-confirm-strong.el new file mode 100644 index 000000000..26c008228 --- /dev/null +++ b/tests/test-system-lib-confirm-strong.el @@ -0,0 +1,37 @@ +;;; test-system-lib-confirm-strong.el --- Tests for cj/confirm-strong -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/confirm-strong', the typed-"yes" confirmation used for +;; irreversible actions. The behavior under test is the long-form guarantee: +;; the prompt demands a typed yes/no even when the global single-key default +;; (`use-short-answers') is in effect. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'system-lib) + +(ert-deftest test-system-lib-confirm-strong-returns-t-on-yes () + "Normal: passes a t answer through from `yes-or-no-p'." + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t))) + (should (eq (cj/confirm-strong "Really? ") t)))) + +(ert-deftest test-system-lib-confirm-strong-returns-nil-on-no () + "Normal: passes a nil answer through from `yes-or-no-p'." + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) nil))) + (should (eq (cj/confirm-strong "Really? ") nil)))) + +(ert-deftest test-system-lib-confirm-strong-forces-long-form () + "Boundary: binds `use-short-answers' to nil for the call even when it is +globally t, so the irreversible prompt requires a typed yes/no regardless of +the single-key default." + (let ((use-short-answers t) + (seen 'unset)) + (cl-letf (((symbol-function 'yes-or-no-p) + (lambda (&rest _) (setq seen use-short-answers) t))) + (cj/confirm-strong "Really? ") + (should (eq seen nil))))) + +(provide 'test-system-lib-confirm-strong) +;;; test-system-lib-confirm-strong.el ends here diff --git a/tests/test-system-lib-font-lock-global-modes.el b/tests/test-system-lib-font-lock-global-modes.el new file mode 100644 index 000000000..e074bd256 --- /dev/null +++ b/tests/test-system-lib-font-lock-global-modes.el @@ -0,0 +1,46 @@ +;;; test-system-lib-font-lock-global-modes.el --- Tests for the font-lock exclusion helper -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/--font-lock-global-modes-excluding', the pure transform +;; behind `cj/exclude-from-global-font-lock'. Some major modes (dashboard, +;; mu4e) paint their buffers with manual `face' text properties; global +;; font-lock then strips those. The helper adds a mode to the +;; `font-lock-global-modes' exclusion, handling its three shapes: t (all +;; modes on), a (not M...) exclusion list, and an (M...) inclusion list. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'system-lib) + +(ert-deftest test-system-lib-flgm-from-t-builds-not-list () + "Normal: t (all modes on) becomes a (not MODE) exclusion." + (let ((r (cj/--font-lock-global-modes-excluding t 'dashboard-mode))) + (should (eq (car r) 'not)) + (should (memq 'dashboard-mode (cdr r))))) + +(ert-deftest test-system-lib-flgm-adds-to-existing-not-list () + "Normal: a second mode is added to an existing (not ...) list." + (let ((r (cj/--font-lock-global-modes-excluding '(not dashboard-mode) 'mu4e-headers-mode))) + (should (eq (car r) 'not)) + (should (memq 'dashboard-mode (cdr r))) + (should (memq 'mu4e-headers-mode (cdr r))))) + +(ert-deftest test-system-lib-flgm-idempotent-on-already-excluded () + "Boundary: excluding an already-excluded mode does not duplicate it." + (let ((r (cj/--font-lock-global-modes-excluding '(not a-mode) 'a-mode))) + (should (eq (car r) 'not)) + (should (= 1 (cl-count 'a-mode (cdr r)))))) + +(ert-deftest test-system-lib-flgm-removes-from-inclusion-list () + "Boundary: in an (M...) inclusion list, excluding a mode removes it." + (should (equal (cj/--font-lock-global-modes-excluding '(foo-mode bar-mode) 'foo-mode) + '(bar-mode)))) + +(ert-deftest test-system-lib-flgm-nil-stays-nil () + "Boundary: nil (no mode gets global font-lock) already excludes everything." + (should (equal (cj/--font-lock-global-modes-excluding nil 'x-mode) nil))) + +(provide 'test-system-lib-font-lock-global-modes) +;;; test-system-lib-font-lock-global-modes.el ends here diff --git a/tests/test-term-config--f8-in-term.el b/tests/test-term-config--f8-in-term.el deleted file mode 100644 index 6cee4ff46..000000000 --- a/tests/test-term-config--f8-in-term.el +++ /dev/null @@ -1,42 +0,0 @@ -;;; test-term-config--f8-in-term.el --- F8 reaches Emacs from inside a ghostel buffer -*- lexical-binding: t; -*- - -;;; Commentary: -;; <f8> is a global binding (`cj/main-agenda-display', set in org-agenda-config). -;; ghostel's semi-char mode forwards every key NOT in `ghostel-keymap-exceptions' -;; to the terminal program, so a plain <f8> typed while point is in a ghostel -;; buffer would be sent to the program instead of opening the agenda. Unlike the -;; F9 family, F8 is NOT re-bound in `ghostel-mode-map' -- it simply falls through -;; to the global map once the semi-char map stops forwarding it, so the only -;; wiring term-config.el adds is the keymap-exceptions entry plus the rebuild. -;; These tests require ghostel (so term-config's `with-eval-after-load' fires) -;; BEFORE term-config, then confirm the exception landed and the rebuilt -;; semi-char map no longer forwards <f8>. `(require 'ghostel)' does not load the -;; native module, so this stays light. - -;;; Code: - -(require 'ert) -(require 'package) - -(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) -(package-initialize) -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'ghostel) -(require 'term-config) - -(ert-deftest test-term-config-f8-in-keymap-exceptions () - "Regression: <f8> is in `ghostel-keymap-exceptions' so semi-char mode lets it -reach Emacs instead of forwarding it to the terminal program. This is what lets -the global agenda binding work from inside a ghostel buffer." - (should (member "<f8>" ghostel-keymap-exceptions))) - -(ert-deftest test-term-config-f8-not-forwarded-by-semi-char-map () - "Regression: the rebuilt semi-char map must no longer forward <f8> to the pty. -`add-to-list' updates the exceptions list but not the already-built map -- only -`ghostel--rebuild-semi-char-keymap' (run in term-config's :init) drops the -forwarding binding so <f8> falls through to the global agenda command." - (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "<f8>") - 'ghostel--send-event))) - -(provide 'test-term-config--f8-in-term) -;;; test-term-config--f8-in-term.el ends here diff --git a/tests/test-term-tmux-history.el b/tests/test-term-tmux-history.el index 51e9725c4..08d39e5bf 100644 --- a/tests/test-term-tmux-history.el +++ b/tests/test-term-tmux-history.el @@ -1,14 +1,13 @@ -;;; test-term-tmux-history.el --- Tests for term-config tmux history + menu UX -*- lexical-binding: t; -*- +;;; test-term-tmux-history.el --- Tests for the EAT terminal copy-mode + tmux history -*- lexical-binding: t; -*- ;;; Commentary: -;; Exercises the term-config (ghostel) terminal UX: the Emacs-owned tmux -;; history buffer, the copy-mode-dwim engine pick, the tmux pane-id / -;; attached-client predicates, and the C-; x menu bindings. +;; Exercises the terminal UX carried into eat-config for the EAT agent +;; terminals: the Emacs-owned tmux history buffer, the copy-mode-dwim engine +;; pick, the tmux pane-id / attached-client predicates, and the C-; x menu +;; bindings. Agents run EAT over tmux, so copy-mode is tmux's own copy-mode. ;; -;; ghostel is required (which defines `ghostel-mode-map' / -;; `ghostel-keymap-exceptions' and lets term-config's `with-eval-after-load' -;; fire) before term-config. `(require 'ghostel)' does not load the native -;; module; tmux is mocked via `process-file', so nothing spawns. +;; eat is required (so eat-config's `with-eval-after-load' fires for the C-<up> +;; bind) before eat-config; tmux is mocked via `process-file', so nothing spawns. ;;; Code: @@ -21,8 +20,8 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) (setq load-prefer-newer t) -(require 'ghostel) -(require 'term-config) +(require 'eat) +(require 'eat-config) (require 'testutil-ghostel-buffers) (defmacro test-term-tmux-history--with-tmux-mock (responses &rest body) @@ -51,6 +50,8 @@ RESPONSES is an alist of (ARGS EXIT-CODE OUTPUT)." exit-code)))) ,@body))) +;;; tmux helpers + (ert-deftest test-term-tmux-history--pane-id-for-tty-matches-client () "Normal: current terminal pty maps to the active pane for that tmux client." (test-term-tmux-history--with-tmux-mock @@ -66,16 +67,39 @@ RESPONSES is an alist of (ARGS EXIT-CODE OUTPUT)." (should (equal (cj/term--tmux-capture-pane "%8") "first line\nsecond line\n")))) +(ert-deftest test-term-current-tmux-pane-id-rejects-non-eat-buffer () + "Error: pane-id lookup refuses a buffer that is not in `eat-mode'." + (with-temp-buffer + (should-error (cj/term--current-tmux-pane-id) :type 'user-error))) + +(ert-deftest test-term-current-tmux-pane-id-accepts-agent-named-buffer () + "Normal: an agent-named eat buffer resolves by process TTY, not buffer name." + (let ((agent (cj/test--make-fake-eat-buffer "agent [emacs.d]"))) + (unwind-protect + (with-current-buffer agent + (cl-letf (((symbol-function 'get-buffer-process) + (lambda (_buffer) 'fake-process)) + ((symbol-function 'process-tty-name) + (lambda (_process &rest _) "/dev/pts/8"))) + (test-term-tmux-history--with-tmux-mock + '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 + "/dev/pts/1\t%1\n/dev/pts/8\t%8\n")) + (should (equal (cj/term--current-tmux-pane-id) "%8"))))) + (when (buffer-live-p agent) + (kill-buffer agent))))) + +;;; tmux history buffer + (ert-deftest test-term-tmux-history-open-renders-read-only-history-buffer () - "Normal: command renders tmux history in a normal Emacs buffer." - (let ((origin (cj/test--make-fake-ghostel-buffer "*test-term-history-origin*"))) + "Normal: the command renders tmux history in a normal Emacs buffer." + (let ((origin (cj/test--make-fake-eat-buffer "*test-term-history-origin*"))) (unwind-protect (save-window-excursion (switch-to-buffer origin) (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/8\t%8\n") @@ -90,41 +114,8 @@ RESPONSES is an alist of (ARGS EXIT-CODE OUTPUT)." (when (buffer-live-p origin) (kill-buffer origin))))) -(ert-deftest test-term-tmux-history-replaces-origin-buffer-in-same-window () - "Normal: the history view replaces the origin in the selected window. - -`cj/term-tmux-history' uses `switch-to-buffer' so reading scrollback keeps -the terminal's frame slot rather than splitting or popping a new window." - (let ((origin (cj/test--make-fake-ghostel-buffer "*test-term-history-inplace*"))) - (unwind-protect - (save-window-excursion - (delete-other-windows) - (switch-to-buffer origin) - (let ((win (selected-window))) - (should (eq (window-buffer win) origin)) - (should (one-window-p)) - (cl-letf (((symbol-function 'get-buffer-process) - (lambda (_buffer) 'fake-process)) - ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) - (test-term-tmux-history--with-tmux-mock - '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 - "/dev/pts/8\t%8\n") - (("capture-pane" "-p" "-J" "-S" "-" "-E" "-" "-t" "%8") 0 - "scrollback line\n")) - (cj/term-tmux-history))) - (should (one-window-p)) - (should (eq (selected-window) win)) - (should (string-prefix-p - "*terminal tmux history:" - (buffer-name (window-buffer win)))))) - (cj/test--kill-buffers-matching-prefix "*terminal tmux history") - (when (buffer-live-p origin) - (kill-buffer origin))))) - (ert-deftest test-term-tmux-history-quit-returns-to-origin () - "Normal: q / <escape> / C-g (cj/term-tmux-history-quit) kills the history -buffer and restores the origin buffer, window, and point." + "Normal: quit kills the history buffer and restores origin buffer/window/point." (let ((origin (get-buffer-create "*test-term-history-return*"))) (unwind-protect (let ((history (get-buffer-create "*terminal tmux history: test*"))) @@ -149,10 +140,8 @@ buffer and restores the origin buffer, window, and point." (kill-buffer origin))))) (ert-deftest test-term-tmux-history-mode-keymap () - "Normal: in the history buffer M-w copies without quitting; q, <escape>, -and C-g quit back to the terminal; RET is left unbound (no special exit)." - (should (eq (keymap-lookup cj/term-tmux-history-mode-map "M-w") - #'kill-ring-save)) + "Normal: M-w copies; q/<escape>/C-g quit; RET is left unbound." + (should (eq (keymap-lookup cj/term-tmux-history-mode-map "M-w") #'kill-ring-save)) (should (eq (keymap-lookup cj/term-tmux-history-mode-map "q") #'cj/term-tmux-history-quit)) (should (eq (keymap-lookup cj/term-tmux-history-mode-map "<escape>") @@ -161,56 +150,17 @@ and C-g quit back to the terminal; RET is left unbound (no special exit)." #'cj/term-tmux-history-quit)) (should-not (keymap-lookup cj/term-tmux-history-mode-map "RET"))) -(ert-deftest test-term-keymap-includes-history-and-copy-bindings () - "Normal: the personal terminal map owns the high-level UX commands, and C-; -reaches Emacs inside ghostel buffers so the prefix works there." - (should (member "C-;" ghostel-keymap-exceptions)) - (should (eq (keymap-lookup cj/custom-keymap "x h") #'cj/term-tmux-history)) - (should (eq (keymap-lookup cj/custom-keymap "x c") #'cj/term-copy-mode-dwim)) - (should (equal (keymap-lookup ghostel-mode-map "C-;") cj/custom-keymap)) - (should (eq (keymap-lookup ghostel-mode-map "C-; x h") #'cj/term-tmux-history)) - (should (eq (keymap-lookup ghostel-mode-map "C-; x c") #'cj/term-copy-mode-dwim))) - -(ert-deftest test-term-keymap-prompt-navigation () - "Normal: n/p navigate prompts, capital N creates a new terminal buffer." - (should (eq (keymap-lookup cj/custom-keymap "x n") #'ghostel-next-prompt)) - (should (eq (keymap-lookup cj/custom-keymap "x p") #'ghostel-previous-prompt)) - (should (eq (keymap-lookup cj/custom-keymap "x N") #'ghostel))) - -(ert-deftest test-term-current-tmux-pane-id-rejects-non-ghostel-buffer () - "Error: pane-id lookup refuses a buffer that is not in `ghostel-mode'." - (with-temp-buffer - (should-error (cj/term--current-tmux-pane-id) :type 'user-error))) - -(ert-deftest test-term-current-tmux-pane-id-accepts-agent-named-buffer () - "Normal: an agent-named ghostel buffer resolves by process TTY. - -The pane lookup keys off the live process TTY, never the buffer name, so a -buffer named `agent [repo]' (ai-term.el's naming) resolves like any other -ghostel-mode terminal." - (let ((agent (cj/test--make-fake-ghostel-buffer "agent [emacs.d]"))) - (unwind-protect - (with-current-buffer agent - (cl-letf (((symbol-function 'get-buffer-process) - (lambda (_buffer) 'fake-process)) - ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) - (test-term-tmux-history--with-tmux-mock - '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 - "/dev/pts/1\t%1\n/dev/pts/8\t%8\n")) - (should (equal (cj/term--current-tmux-pane-id) "%8"))))) - (when (buffer-live-p agent) - (kill-buffer agent))))) +;;; in-tmux-p predicate (ert-deftest test-term-in-tmux-p-true-when-client-attached () "Normal: predicate returns t when tmux reports a client for our tty." - (let ((agent (cj/test--make-fake-ghostel-buffer "agent [emacs.d]"))) + (let ((agent (cj/test--make-fake-eat-buffer "agent [emacs.d]"))) (unwind-protect (with-current-buffer agent (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/8\t%8\n")) @@ -218,31 +168,24 @@ ghostel-mode terminal." (when (buffer-live-p agent) (kill-buffer agent))))) -(ert-deftest test-term-in-tmux-p-nil-when-no-matching-client () - "Boundary: predicate returns nil when tmux runs but our tty has no client." - (let ((agent (cj/test--make-fake-ghostel-buffer "agent [emacs.d]"))) - (unwind-protect - (with-current-buffer agent - (cl-letf (((symbol-function 'get-buffer-process) - (lambda (_buffer) 'fake-process)) - ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) - (test-term-tmux-history--with-tmux-mock - '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 - "/dev/pts/1\t%1\n")) - (should-not (cj/term--in-tmux-p))))) - (when (buffer-live-p agent) - (kill-buffer agent))))) +(ert-deftest test-term-in-tmux-p-nil-when-not-eat-mode () + "Boundary: predicate refuses non-eat buffers without calling tmux." + (with-temp-buffer + (let ((tmux-called nil)) + (cl-letf (((symbol-function 'process-file) + (lambda (&rest _) (setq tmux-called t) 0))) + (should-not (cj/term--in-tmux-p)) + (should-not tmux-called))))) (ert-deftest test-term-in-tmux-p-nil-when-tmux-fails () "Error: predicate swallows tmux failures and returns nil." - (let ((agent (cj/test--make-fake-ghostel-buffer "agent [emacs.d]"))) + (let ((agent (cj/test--make-fake-eat-buffer "agent [emacs.d]"))) (unwind-protect (with-current-buffer agent (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8"))) + (lambda (_process &rest _) "/dev/pts/8"))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 1 "no server running")) @@ -250,109 +193,85 @@ ghostel-mode terminal." (when (buffer-live-p agent) (kill-buffer agent))))) -(ert-deftest test-term-in-tmux-p-nil-when-not-ghostel-mode () - "Boundary: predicate refuses non-ghostel buffers without calling tmux." - (with-temp-buffer - (let ((tmux-called nil)) - (cl-letf (((symbol-function 'process-file) - (lambda (&rest _) (setq tmux-called t) 0))) - (should-not (cj/term--in-tmux-p)) - (should-not tmux-called))))) +;;; copy-mode (tmux path -- the agent terminal case) (ert-deftest test-term-copy-mode-dwim-sends-tmux-prefix-when-attached () - "Normal: with tmux attached, dwim writes C-b [ then C-a into the pty so -tmux enters its own copy-mode and lands the cursor at the start of the -line. Without the trailing C-a the cursor inherits the live column (far -right after a prompt) and scrolling up runs up the right edge; start-of-line -puts it at column 0 so it runs up the left." - (let ((agent (cj/test--make-fake-ghostel-buffer "agent [emacs.d]")) - (sent nil) - (copy-mode-called nil)) + "Normal: with tmux attached, dwim writes C-b [ then C-a into the pty so tmux +enters copy-mode with the cursor at column 0." + (let ((agent (cj/test--make-fake-eat-buffer "agent [emacs.d]")) + (sent nil)) (unwind-protect (with-current-buffer agent (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8")) - ((symbol-function 'ghostel-send-string) - (lambda (s) (push s sent))) - ((symbol-function 'ghostel-copy-mode) - (lambda () (setq copy-mode-called t)))) + (lambda (_process &rest _) "/dev/pts/8")) + ((symbol-function 'cj/--term-send-string) + (lambda (s) (push s sent)))) (test-term-tmux-history--with-tmux-mock '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 "/dev/pts/8\t%8\n")) (cj/term-copy-mode-dwim) - (should (equal sent '("\C-b[\C-a"))) - (should-not copy-mode-called)))) + (should (equal sent '("\C-b[\C-a")))))) (when (buffer-live-p agent) (kill-buffer agent))))) -(ert-deftest test-term-copy-mode-dwim-falls-back-without-tmux () - "Boundary: without tmux, dwim calls `ghostel-copy-mode' then moves point -to the start of the line and sends nothing to the pty. The -`beginning-of-line' must run after `ghostel-copy-mode' so it repositions -inside the copy view; column 0 keeps the cursor on the left edge while -scrolling, parity with the tmux branch's trailing C-a." - (let ((agent (cj/test--make-fake-ghostel-buffer "agent [emacs.d]")) - (sent nil) - (dwim-order nil)) +(ert-deftest test-term-copy-mode-up-tmux-enters-then-scrolls-up () + "Normal: from a live (non-copy) tmux pane, C-<up> enters copy-mode then sends +the up-arrow, so one stroke both enters copy-mode and scrolls up." + (let ((agent (cj/test--make-fake-eat-buffer "agent [emacs.d]")) + (sent nil)) (unwind-protect (with-current-buffer agent (cl-letf (((symbol-function 'get-buffer-process) (lambda (_buffer) 'fake-process)) ((symbol-function 'process-tty-name) - (lambda (_process) "/dev/pts/8")) - ((symbol-function 'ghostel-send-string) - (lambda (s) (push s sent))) - ((symbol-function 'ghostel-copy-mode) - (lambda () (push 'copy-mode dwim-order))) - ((symbol-function 'beginning-of-line) - (lambda (&optional _n) (push 'beginning-of-line dwim-order)))) + (lambda (_process &rest _) "/dev/pts/8")) + ((symbol-function 'cj/--term-send-string) + (lambda (s) (push s sent)))) (test-term-tmux-history--with-tmux-mock - '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 1 - "no server running")) - (cj/term-copy-mode-dwim) - (should-not sent) - (should (equal (reverse dwim-order) '(copy-mode beginning-of-line)))))) + '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 + "/dev/pts/8\t%8\n") + (("display-message" "-p" "-t" "%8" "#{pane_in_mode}") 0 "0\n")) + (cj/term-copy-mode-up) + (should (equal (reverse sent) '("\C-b[\C-a" "\e[A")))))) (when (buffer-live-p agent) (kill-buffer agent))))) -(ert-deftest test-term-prefix-and-f12-in-keymap-exceptions () - "Regression: C-; and F12 are in `ghostel-keymap-exceptions' and the rebuilt -semi-char map no longer forwards them to the pty, so the prefix keymap and the -F12 toggle reach Emacs inside ghostel buffers." - (dolist (key '("C-;" "<f12>")) - (should (member key ghostel-keymap-exceptions))) - (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "<f12>") - 'ghostel--send-event))) +(ert-deftest test-term-copy-mode-up-tmux-already-in-mode-just-scrolls () + "Normal: when the tmux pane is already in copy-mode, C-<up> only sends the +up-arrow -- it does not re-enter and reset the cursor." + (let ((agent (cj/test--make-fake-eat-buffer "agent [emacs.d]")) + (sent nil)) + (unwind-protect + (with-current-buffer agent + (cl-letf (((symbol-function 'get-buffer-process) + (lambda (_buffer) 'fake-process)) + ((symbol-function 'process-tty-name) + (lambda (_process &rest _) "/dev/pts/8")) + ((symbol-function 'cj/--term-send-string) + (lambda (s) (push s sent)))) + (test-term-tmux-history--with-tmux-mock + '((("list-clients" "-F" "#{client_tty}\t#{pane_id}") 0 + "/dev/pts/8\t%8\n") + (("display-message" "-p" "-t" "%8" "#{pane_in_mode}") 0 "1\n")) + (cj/term-copy-mode-up) + (should (equal (reverse sent) '("\e[A")))))) + (when (buffer-live-p agent) + (kill-buffer agent))))) -(ert-deftest test-term-window-nav-keys-in-keymap-exceptions () - "Regression: windmove (S-arrows) and buffer-move (C-M-arrows) are in -`ghostel-keymap-exceptions' so they reach Emacs from inside a ghostel buffer -instead of being forwarded to the terminal program." - (dolist (key '("S-<up>" "S-<down>" "S-<left>" "S-<right>" - "C-M-<up>" "C-M-<down>" "C-M-<left>" "C-M-<right>")) - (should (member key ghostel-keymap-exceptions))) - (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "C-M-<left>") - 'ghostel--send-event))) +;;; bindings -(ert-deftest test-term-f10-music-and-shutdown-in-keymap-exceptions () - "Regression: F10 (music playlist toggle) and C-F10 (server shutdown) are in -`ghostel-keymap-exceptions' so they reach Emacs from inside a ghostel buffer -instead of being forwarded to the terminal program. Both are global bindings, -so dropping them from the semi-char map lets the lookup fall through to the -global map." - (dolist (key '("<f10>" "C-<f10>")) - (should (member key ghostel-keymap-exceptions))) - (should-not (eq (keymap-lookup ghostel-semi-char-mode-map "<f10>") - 'ghostel--send-event))) +(ert-deftest test-term-keymap-history-and-copy-bindings () + "Normal: the C-; x terminal map owns the tmux-history and copy-mode commands." + (should (eq (keymap-lookup cj/custom-keymap "x h") #'cj/term-tmux-history)) + (should (eq (keymap-lookup cj/custom-keymap "x c") #'cj/term-copy-mode-dwim)) + (should (eq (keymap-lookup cj/custom-keymap "x t") #'cj/term-toggle))) -(ert-deftest test-term-c-spc-forwarded-not-set-mark () - "Regression: C-SPC is forwarded to the terminal, not bound to the global -`set-mark-command'. ghostel only forwards the `C-@' event, so without this an -Emacs region gets stuck in the ghostel buffer and tmux copy-mode's -begin-selection never starts." - (should (eq (keymap-lookup ghostel-mode-map "C-SPC") #'cj/term-send-C-SPC))) +(ert-deftest test-term-copy-mode-up-bound-in-eat-semi-char-map () + "Normal: C-<up> enters copy-mode + scrolls up from inside an EAT terminal." + (should (eq (keymap-lookup eat-semi-char-mode-map "C-<up>") + #'cj/term-copy-mode-up))) (provide 'test-term-tmux-history) ;;; test-term-tmux-history.el ends here diff --git a/tests/test-term-toggle--buffer-filter.el b/tests/test-term-toggle--buffer-filter.el index 2c96ecb38..6db2ec65c 100644 --- a/tests/test-term-toggle--buffer-filter.el +++ b/tests/test-term-toggle--buffer-filter.el @@ -1,11 +1,12 @@ ;;; test-term-toggle--buffer-filter.el --- Tests for F12's buffer filter -*- lexical-binding: t; -*- ;;; Commentary: -;; Three closely-related helpers determine which terminal buffers F12 -;; manages: the predicate `cj/--term-toggle-buffer-p', the MRU list +;; Three closely-related helpers determine which terminal buffer F12 +;; manages: the predicate `cj/--term-toggle-buffer-p', the list ;; `cj/--term-toggle-buffers', and the per-frame window finder -;; `cj/--term-toggle-displayed-window'. All three exclude agent- -;; prefixed buffers so agent has its own F9 surface. +;; `cj/--term-toggle-displayed-window'. F12 opens eshell (run through EAT via +;; eat-eshell-mode), so it manages eshell-mode buffers. Standalone eat buffers, +;; ghostel buffers, and ai-term's agent buffers are NOT F12-managed. ;;; Code: @@ -13,7 +14,7 @@ (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 'term-config) +(require 'eat-config) (require 'testutil-ghostel-buffers) (defun test-term-toggle--cleanup () @@ -21,16 +22,24 @@ (cj/test--kill-agent-buffers) (cj/test--kill-test-term-buffers)) -(ert-deftest test-term-toggle--buffer-p-accepts-ghostel-mode () - "Normal: a ghostel-mode buffer with non-agent name qualifies." +(ert-deftest test-term-toggle--buffer-p-accepts-eshell-mode () + "Normal: an eshell-mode buffer qualifies as the F12 terminal." (test-term-toggle--cleanup) - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-term-1*"))) + (let ((buf (cj/test--make-fake-eshell-buffer "*test-term-1*"))) (unwind-protect (should (cj/--term-toggle-buffer-p buf)) (kill-buffer buf)))) +(ert-deftest test-term-toggle--buffer-p-rejects-eat () + "Boundary: a standalone eat buffer is NOT F12-managed (F12 opens eshell)." + (test-term-toggle--cleanup) + (let ((buf (cj/test--make-fake-eat-buffer "*test-term-eat*"))) + (unwind-protect + (should-not (cj/--term-toggle-buffer-p buf)) + (kill-buffer buf)))) + (ert-deftest test-term-toggle--buffer-p-rejects-agent () - "Boundary: agent-prefixed terminal buffers are excluded from F12's set." + "Boundary: ai-term agent buffers are excluded from F12's set." (test-term-toggle--cleanup) (let ((buf (cj/test--make-fake-ghostel-buffer "agent [project-a]"))) (unwind-protect @@ -38,7 +47,7 @@ (kill-buffer buf)))) (ert-deftest test-term-toggle--buffer-p-rejects-non-terminal () - "Boundary: a regular buffer (not ghostel-mode, no terminal name prefix) -> nil." + "Boundary: a regular buffer (not eshell-mode) -> nil." (test-term-toggle--cleanup) (let ((buf (get-buffer-create "*test-term-regular*"))) (unwind-protect @@ -48,35 +57,35 @@ (ert-deftest test-term-toggle--buffer-p-rejects-dead-buffer () "Boundary: nil and dead buffers -> nil." (should-not (cj/--term-toggle-buffer-p nil)) - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-term-dead*"))) + (let ((buf (cj/test--make-fake-eshell-buffer "*test-term-dead*"))) (kill-buffer buf) (should-not (cj/--term-toggle-buffer-p buf)))) -(ert-deftest test-term-toggle--buffers-filters-agent () - "Normal: returns terminal buffers but excludes agent-prefixed ones." +(ert-deftest test-term-toggle--buffers-returns-eshell-excludes-others () + "Normal: returns the eshell terminal but not eat/agent buffers." (test-term-toggle--cleanup) - (let ((normal (cj/test--make-fake-ghostel-buffer "*test-term-normal*")) + (let ((esh (cj/test--make-fake-eshell-buffer "*test-term-esh*")) (agent (cj/test--make-fake-ghostel-buffer "agent [for-test]"))) (unwind-protect (let ((result (cj/--term-toggle-buffers))) - (should (memq normal result)) + (should (memq esh result)) (should-not (memq agent result))) - (kill-buffer normal) + (kill-buffer esh) (kill-buffer agent)))) (ert-deftest test-term-toggle--displayed-window-finds-terminal () - "Normal: terminal in a window -> returns that window." + "Normal: the eshell terminal in a window -> returns that window." (test-term-toggle--cleanup) - (let ((vt (cj/test--make-fake-ghostel-buffer "*test-term-shown*"))) + (let ((esh (cj/test--make-fake-eshell-buffer "*test-term-shown*"))) (unwind-protect (save-window-excursion (delete-other-windows) (let ((win (split-window-right))) - (set-window-buffer win vt) + (set-window-buffer win esh) (let ((result (cj/--term-toggle-displayed-window))) (should (windowp result)) - (should (eq (window-buffer result) vt))))) - (kill-buffer vt)))) + (should (eq (window-buffer result) esh))))) + (kill-buffer esh)))) (ert-deftest test-term-toggle--displayed-window-skips-agent () "Boundary: only an agent terminal is displayed -> nil (agent not F12-managed)." diff --git a/tests/test-term-toggle--dispatch.el b/tests/test-term-toggle--dispatch.el index f13c2840b..0d17395cc 100644 --- a/tests/test-term-toggle--dispatch.el +++ b/tests/test-term-toggle--dispatch.el @@ -14,7 +14,7 @@ (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 'term-config) +(require 'eat-config) (require 'testutil-ghostel-buffers) (ert-deftest test-term-toggle--dispatch-window-displayed-returns-toggle-off () diff --git a/tests/test-term-toggle--display.el b/tests/test-term-toggle--display.el index 0943a4888..d59d23b15 100644 --- a/tests/test-term-toggle--display.el +++ b/tests/test-term-toggle--display.el @@ -14,10 +14,12 @@ (require 'cl-lib) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'term-config) +(require 'eat-config) (ert-deftest test-term-toggle--capture-state-records-direction-and-size () - "Normal: capture-state writes direction and integer body size." + "Normal: capture-state writes direction and integer size. +The vertical axis captures total-height (not body-height) so the toggle +round-trip is immune to the mode line's pixel height." (save-window-excursion (delete-other-windows) (let ((below (split-window (selected-window) nil 'below)) @@ -26,7 +28,7 @@ (cj/--term-toggle-capture-state below) (should (eq cj/--term-toggle-last-direction 'below)) (should (integerp cj/--term-toggle-last-size)) - (should (= cj/--term-toggle-last-size (window-body-height below)))))) + (should (= cj/--term-toggle-last-size (window-total-height below)))))) (ert-deftest test-term-toggle--capture-state-noop-on-dead-window () "Boundary: nil window -> state remains unchanged." @@ -50,7 +52,9 @@ (should (eq (cdr (assq 'inhibit-same-window received-alist)) t)))) (ert-deftest test-term-toggle--display-saved-maps-cardinal-to-edge () - "Normal: saved 'below maps to bottom edge; integer size wraps in body-lines." + "Normal: saved 'below maps to bottom edge; integer size is a plain total-line count. +The height axis replays a total-line integer (not a body-lines cons) so the +round-trip is immune to the mode line's pixel height." (let (received-alist (cj/--term-toggle-last-direction 'below) (cj/--term-toggle-last-size 12)) @@ -58,8 +62,7 @@ (lambda (_b a) (setq received-alist a) 'fake-window))) (cj/--term-toggle-display-saved 'fake-buf nil)) (should (eq (cdr (assq 'direction received-alist)) 'bottom)) - (should (equal (cdr (assq 'window-height received-alist)) - '(body-lines . 12))) + (should (equal (cdr (assq 'window-height received-alist)) 12)) (should-not (assq 'window-width received-alist)))) (ert-deftest test-term-toggle--display-saved-strips-conflicting-alist-entries () @@ -83,5 +86,29 @@ received-alist))) (should (null wh-cells))))) +(ert-deftest test-term-toggle--default-size-pairs-width-with-right () + "Normal: the default size for `right' is the width fraction." + (let ((cj/term-toggle-window-width 0.5) + (cj/term-toggle-window-height 0.7)) + (should (= (cj/--term-toggle-default-size 'right) 0.5)))) + +(ert-deftest test-term-toggle--default-size-pairs-height-with-below () + "Normal: the default size for `below' is the height fraction." + (let ((cj/term-toggle-window-width 0.5) + (cj/term-toggle-window-height 0.7)) + (should (= (cj/--term-toggle-default-size 'below) 0.7)))) + +(ert-deftest test-term-toggle--default-direction-delegates-to-dock-rule () + "Normal: default-direction passes the width fraction to the dock rule." + (let ((cj/term-toggle-window-width 0.5) + captured) + (cl-letf (((symbol-function 'cj/preferred-dock-direction) + (lambda (cols frac &rest _) + (setq captured (list cols frac)) + 'right))) + (should (eq (cj/--term-toggle-default-direction) 'right)) + (should (= (nth 1 captured) 0.5)) + (should (integerp (nth 0 captured)))))) + (provide 'test-term-toggle--display) ;;; test-term-toggle--display.el ends here diff --git a/tests/test-transcription-process-and-sentinel.el b/tests/test-transcription-process-and-sentinel.el index 330a0260b..90b56f0a5 100644 --- a/tests/test-transcription-process-and-sentinel.el +++ b/tests/test-transcription-process-and-sentinel.el @@ -26,7 +26,7 @@ (let (msg) (cl-letf (((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args)))) - ((symbol-function 'getenv) (lambda (_) nil))) + ((symbol-function 'getenv) (lambda (_ &rest _) nil))) (cj/--notify "Transcription" "started")) (should (equal msg "Transcription: started")))) @@ -36,7 +36,7 @@ the title, body, and urgency." (let (notify-kwargs) (cl-letf (((symbol-function 'message) #'ignore) ((symbol-function 'getenv) - (lambda (var) (and (equal var "DISPLAY") ":0"))) + (lambda (var &rest _) (and (equal var "DISPLAY") ":0"))) ((symbol-function 'notifications-notify) (lambda (&rest kwargs) (setq notify-kwargs kwargs)))) (cj/--notify "Transcription" "done" 'critical)) diff --git a/tests/test-transcription-status-and-commands.el b/tests/test-transcription-status-and-commands.el index 7c796de0e..af7255cdc 100644 --- a/tests/test-transcription-status-and-commands.el +++ b/tests/test-transcription-status-and-commands.el @@ -138,7 +138,7 @@ (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) ((symbol-function 'kill-process) - (lambda (p) (setq killed p))) + (lambda (p &rest _) (setq killed p))) ((symbol-function 'message) (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) diff --git a/tests/test-transcription-video.el b/tests/test-transcription-video.el index 8327fa326..aa8383d12 100644 --- a/tests/test-transcription-video.el +++ b/tests/test-transcription-video.el @@ -128,6 +128,28 @@ goes through `cj/--start-transcription-process' with a cleanup hint." ;; deleted after transcription completes). (should (equal (nth 1 extract-args) (cadr worker-call))))) +(ert-deftest test-tx-transcribe-media-video-output-base-is-the-source () + "Regression: a video's transcript derives from the VIDEO path (alongside the +source), not the temp /tmp audio. The worker gets the video as its output base +\(third arg), so cj/--transcription-output-files lands talk.mp4 -> talk.txt +beside the video instead of in /tmp." + (let* ((tmp (make-temp-file "cj-tx-vid-" nil ".mp4")) + worker-call) + (unwind-protect + (cl-letf (((symbol-function 'cj/--extract-audio-from-video) + (lambda (_vid _out cb) (funcall cb))) + ((symbol-function 'cj/--start-transcription-process) + (lambda (file &rest rest) + (setq worker-call (cons file rest)) + 'fake-proc))) + (cj/transcribe-media tmp)) + (delete-file tmp)) + ;; the output base (third arg) is the source video, not the temp audio + (should (equal (nth 2 worker-call) tmp)) + ;; so the derived transcript sits beside the video, not in /tmp + (should (equal (car (cj/--transcription-output-files (nth 2 worker-call))) + (concat (file-name-sans-extension tmp) ".txt"))))) + (ert-deftest test-tx-transcribe-media-rejects-non-media () "Error: non-media paths get rejected up front." (should-error (cj/transcribe-media "/notes/readme.txt") :type 'user-error)) diff --git a/tests/test-ui-buffer-status-colors.el b/tests/test-ui-buffer-status-colors.el deleted file mode 100644 index bb905ad4d..000000000 --- a/tests/test-ui-buffer-status-colors.el +++ /dev/null @@ -1,221 +0,0 @@ -;;; test-ui-buffer-status-colors.el --- Tests for buffer status colors -*- lexical-binding: t; -*- - -;;; Commentary: -;; Unit tests for buffer status color system. -;; Tests the state detection logic used by both cursor color and modeline. - -;;; Code: - -(require 'ert) -(require 'user-constants) -(require 'ui-config) -(require 'modeline-config) - -;;; Color Constant Tests - -(ert-deftest test-buffer-status-colors-has-all-states () - "Test that all required states are defined in color alist." - (should (alist-get 'read-only cj/buffer-status-colors)) - (should (alist-get 'overwrite cj/buffer-status-colors)) - (should (alist-get 'modified cj/buffer-status-colors)) - (should (alist-get 'unmodified cj/buffer-status-colors))) - -(ert-deftest test-buffer-status-colors-values-are-strings () - "Test that all color values are strings (hex colors)." - (dolist (entry cj/buffer-status-colors) - (should (stringp (cdr entry))) - ;; Check if it looks like a hex color - (should (string-match-p "^#[0-9a-fA-F]\\{6\\}$" (cdr entry))))) - -;;; Cursor Color State Detection Tests - -(ert-deftest test-cursor-color-state-read-only-buffer () - "Test state detection for read-only buffer." - (with-temp-buffer - (setq buffer-read-only t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'read-only))))) - -(ert-deftest test-cursor-color-state-overwrite-mode () - "Test state detection for overwrite mode." - (with-temp-buffer - (setq buffer-read-only nil) - (overwrite-mode 1) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'overwrite))))) - -(ert-deftest test-cursor-color-state-modified-buffer () - "Test state detection for modified buffer." - (with-temp-buffer - (setq buffer-read-only nil) - (insert "test") - (set-buffer-modified-p t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'modified))))) - -(ert-deftest test-cursor-color-state-unmodified-buffer () - "Test state detection for unmodified buffer." - (with-temp-buffer - (setq buffer-read-only nil) - (set-buffer-modified-p nil) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'unmodified))))) - -(ert-deftest test-cursor-color-state-priority-read-only-over-modified () - "Test that read-only state takes priority over modified state." - (with-temp-buffer - (insert "test") - (set-buffer-modified-p t) - (setq buffer-read-only t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'read-only))))) - -(ert-deftest test-cursor-color-state-priority-overwrite-over-modified () - "Test that overwrite mode takes priority over modified state." - (with-temp-buffer - (insert "test") - (set-buffer-modified-p t) - (overwrite-mode 1) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'overwrite))))) - -;;; Integration Tests - Cursor Color Function - -(ert-deftest test-cursor-color-function-exists () - "Test that cursor color function is defined." - (should (fboundp 'cj/set-cursor-color-according-to-mode))) - -(ert-deftest test-cursor-color-returns-correct-color-for-read-only () - "Test cursor color function returns red for read-only buffer." - (with-temp-buffer - (setq buffer-read-only t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#f06a3f"))))) - -(ert-deftest test-cursor-color-returns-correct-color-for-overwrite () - "Test cursor color function returns gold for overwrite mode." - (with-temp-buffer - (overwrite-mode 1) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#c48702"))))) - -(ert-deftest test-cursor-color-returns-correct-color-for-modified () - "Test cursor color function returns green for modified buffer." - (with-temp-buffer - (insert "test") - (set-buffer-modified-p t) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#64aa0f"))))) - -(ert-deftest test-cursor-color-returns-correct-color-for-unmodified () - "Test cursor color function returns white for unmodified buffer." - (with-temp-buffer - (set-buffer-modified-p nil) - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified))) - (color (alist-get state cj/buffer-status-colors))) - (should (equal color "#ffffff"))))) - -;;; Modeline Integration Tests - -(ert-deftest test-modeline-buffer-name-variable-exists () - "Test that modeline buffer name variable is defined." - (should (boundp 'cj/modeline-buffer-name))) - -(ert-deftest test-modeline-buffer-name-is-mode-line-construct () - "Test that modeline buffer name is a valid mode-line construct." - (should (listp cj/modeline-buffer-name)) - (should (eq (car cj/modeline-buffer-name) :eval))) - -;;; Edge Cases - -(ert-deftest test-buffer-status-new-buffer-starts-unmodified () - "Test that new buffer starts in unmodified state." - (with-temp-buffer - (let* ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'unmodified))))) - -(ert-deftest test-buffer-status-insert-makes-modified () - "Test that inserting text changes state to modified." - (with-temp-buffer - ;; Initially unmodified - (set-buffer-modified-p nil) - (let ((state1 (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state1 'unmodified))) - - ;; Insert text - (insert "test") - (let ((state2 (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state2 'modified))))) - -(ert-deftest test-buffer-status-explicit-unmodify () - "Test that explicitly setting unmodified works." - (with-temp-buffer - (insert "test") - (should (buffer-modified-p)) - - ;; Explicitly set unmodified - (set-buffer-modified-p nil) - (let ((state (cond - (buffer-read-only 'read-only) - (overwrite-mode 'overwrite) - ((buffer-modified-p) 'modified) - (t 'unmodified)))) - (should (eq state 'unmodified))))) - -(provide 'test-ui-buffer-status-colors) -;;; test-ui-buffer-status-colors.el ends here diff --git a/tests/test-ui-config--buffer-cursor-state.el b/tests/test-ui-config--buffer-cursor-state.el deleted file mode 100644 index 852865869..000000000 --- a/tests/test-ui-config--buffer-cursor-state.el +++ /dev/null @@ -1,96 +0,0 @@ -;;; test-ui-config--buffer-cursor-state.el --- Tests for cursor-state classification -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/--buffer-cursor-state' picks the buffer-state symbol that -;; `cj/set-cursor-color-according-to-mode' maps to a cursor color via -;; `cj/buffer-status-colors'. The subtle case: a live ghostel terminal is -;; technically `buffer-read-only' but the user types into it -- keystrokes go -;; to the terminal process -- so it must report a writeable state, not -;; `read-only'. ghostel's `copy' / `emacs' input modes are the exception: -;; there the buffer really is a read-only Emacs buffer the user navigates, so -;; `read-only' (the orange cursor) is correct and kept. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) -(setq load-prefer-newer t) -(defvar ghostel--input-mode nil) -(require 'ui-config) -(require 'testutil-ghostel-buffers) - -(ert-deftest test-ui-config-buffer-cursor-state-readwrite-unmodified () - "Normal: a clean writeable buffer reports `unmodified'." - (with-temp-buffer - (set-buffer-modified-p nil) - (should (eq (cj/--buffer-cursor-state) 'unmodified)))) - -(ert-deftest test-ui-config-buffer-cursor-state-readwrite-modified () - "Normal: a writeable buffer with unsaved changes reports `modified'." - (with-temp-buffer - (insert "x") - (should (eq (cj/--buffer-cursor-state) 'modified)))) - -(ert-deftest test-ui-config-buffer-cursor-state-read-only () - "Normal: a plain read-only buffer reports `read-only'." - (with-temp-buffer - (setq buffer-read-only t) - (should (eq (cj/--buffer-cursor-state) 'read-only)))) - -(ert-deftest test-ui-config-buffer-cursor-state-overwrite () - "Boundary: `overwrite-mode' wins over the modified/unmodified split." - (with-temp-buffer - (insert "x") - (overwrite-mode 1) - (should (eq (cj/--buffer-cursor-state) 'overwrite)))) - -(ert-deftest test-ui-config-buffer-cursor-state-live-ghostel-is-writeable () - "Boundary: a live ghostel buffer is `buffer-read-only' but reports a -writeable state -- the user types into the terminal process there, so the -read-only (orange) cursor would be misleading." - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-ghostel-cursor-state*"))) - (unwind-protect - (with-current-buffer buf - (setq buffer-read-only t) ; ghostel keeps the buffer read-only - (setq-local ghostel--input-mode 'semi-char) - (should-not (eq (cj/--buffer-cursor-state) 'read-only))) - (when (buffer-live-p buf) (kill-buffer buf))))) - -(ert-deftest test-ui-config-buffer-cursor-state-ghostel-copy-mode-is-read-only () - "Boundary: in ghostel `copy' mode the buffer is a read-only Emacs buffer -the user navigates, so `read-only' (orange) is kept." - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-ghostel-cursor-state-copy*"))) - (unwind-protect - (with-current-buffer buf - (setq buffer-read-only t) - (setq-local ghostel--input-mode 'copy) - (should (eq (cj/--buffer-cursor-state) 'read-only))) - (when (buffer-live-p buf) (kill-buffer buf))))) - -(ert-deftest test-ui-config-set-cursor-color-live-ghostel-not-orange () - "Normal: in a live ghostel terminal the cursor-color hook picks a writeable -color, not the read-only orange -- even though the buffer is read-only. -`display-graphic-p' is stubbed t so the function reaches its work body in -batch mode (the live function no-ops on TTY frames by design)." - (let ((buf (cj/test--make-fake-ghostel-buffer "*test-ghostel-cursor-color*")) - (applied 'unset)) - (unwind-protect - (with-current-buffer buf - (setq buffer-read-only t) - (setq-local ghostel--input-mode 'semi-char) - (let ((cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) - ((symbol-function 'set-cursor-color) - (lambda (c) (setq applied c)))) - (cj/set-cursor-color-according-to-mode))) - (should (stringp applied)) - (should-not (equal applied - (alist-get 'read-only cj/buffer-status-colors)))) - (when (buffer-live-p buf) (kill-buffer buf))))) - -(provide 'test-ui-config--buffer-cursor-state) -;;; test-ui-config--buffer-cursor-state.el ends here diff --git a/tests/test-ui-config-transparency-and-cursor.el b/tests/test-ui-config-transparency-and-cursor.el index b01fa2b71..13906773b 100644 --- a/tests/test-ui-config-transparency-and-cursor.el +++ b/tests/test-ui-config-transparency-and-cursor.el @@ -23,7 +23,7 @@ (cj/transparency-level 70) (default-frame-alist nil) (applied nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (_frame param value) (when (eq param 'alpha) (setq applied value))))) @@ -37,7 +37,7 @@ (cj/transparency-level 50) (default-frame-alist '((alpha . (50 . 50)))) (applied nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (_frame param value) (when (eq param 'alpha) (setq applied value))))) @@ -52,7 +52,7 @@ the default-frame-alist so a future graphical frame would pick it up." (cj/transparency-level 60) (default-frame-alist nil) (set-called nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () nil)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) nil)) ((symbol-function 'set-frame-parameter) (lambda (&rest _) (setq set-called t)))) (cj/apply-transparency)) @@ -66,7 +66,7 @@ surfaced via `message'; the default-alist update still happens." (cj/transparency-level 60) (default-frame-alist nil) (msg nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (&rest _) (error "boom"))) ((symbol-function 'message) @@ -83,7 +83,7 @@ surfaced via `message'; the default-alist update still happens." (cj/transparency-level 80) (default-frame-alist nil) (applied nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) (lambda (_frame param value) (when (eq param 'alpha) (setq applied value)))) @@ -97,7 +97,7 @@ surfaced via `message'; the default-alist update still happens." (let ((cj/enable-transparency t) (cj/transparency-level 90) (default-frame-alist nil)) - (cl-letf (((symbol-function 'display-graphic-p) (lambda () t)) + (cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t)) ((symbol-function 'set-frame-parameter) #'ignore) ((symbol-function 'message) #'ignore)) (cj/toggle-transparency) diff --git a/tests/test-ui-cursor-color-integration.el b/tests/test-ui-cursor-color-integration.el deleted file mode 100644 index c28bde923..000000000 --- a/tests/test-ui-cursor-color-integration.el +++ /dev/null @@ -1,175 +0,0 @@ -;;; test-ui-cursor-color-integration.el --- Integration tests for cursor color -*- lexical-binding: t; -*- - -;;; Commentary: -;; Integration tests for cursor color hook behavior. -;; Tests that cursor color actually updates when switching buffers, -;; modifying files, etc. - -;;; Code: - -(require 'ert) -(require 'user-constants) - -;; `cj/set-cursor-color-according-to-mode' and the `post-command-hook' -;; install both gate on `display-graphic-p' -- a TTY / batch run is a -;; no-op for cursor coloring by design. These integration tests -;; exercise the work body, so we pretend we're in a graphical session -;; for the whole file. Stubbing the symbol BEFORE loading ui-config -;; matters because the hook install reads `display-graphic-p' at load -;; time. -(advice-add 'display-graphic-p :around - (lambda (orig &rest args) (or (apply orig args) t))) - -(require 'ui-config) - -;;; Hook Integration Tests - -(ert-deftest test-cursor-color-integration-post-command-hook-installed () - "Test that post-command-hook is installed." - (should (member 'cj/set-cursor-color-according-to-mode post-command-hook))) - -(ert-deftest test-cursor-color-integration-function-runs-without-error () - "Test that cursor color function runs without error in various buffers." - (with-temp-buffer - (should-not (condition-case err - (progn - (cj/set-cursor-color-according-to-mode) - nil) - (error err)))) - - (with-temp-buffer - (setq buffer-read-only t) - (should-not (condition-case err - (progn - (cj/set-cursor-color-according-to-mode) - nil) - (error err))))) - -(ert-deftest test-cursor-color-integration-internal-buffers-ignored () - "Test that internal buffers (starting with space) are ignored." - (let ((internal-buf (get-buffer-create " *test-internal*")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (with-current-buffer internal-buf - (cj/set-cursor-color-according-to-mode) - ;; Cursor state should not have been updated - (should-not cj/-cursor-last-buffer)) - (kill-buffer internal-buf)))) - -(ert-deftest test-cursor-color-integration-normal-buffers-processed () - "Test that normal buffers (not starting with space) are processed." - (let ((normal-buf (get-buffer-create "test-normal")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (with-current-buffer normal-buf - (cj/set-cursor-color-according-to-mode) - ;; Cursor state should have been updated - (should (equal cj/-cursor-last-buffer "test-normal"))) - (kill-buffer normal-buf)))) - -(ert-deftest test-cursor-color-integration-cache-prevents-redundant-updates () - "Test that cache prevents redundant cursor color updates." - (let* ((normal-buf (generate-new-buffer "test-cache")) - (call-count 0) - (advice-fn (lambda (&rest _) (setq call-count (1+ call-count))))) - (unwind-protect - (progn - (advice-add 'set-cursor-color :before advice-fn) - (with-current-buffer normal-buf - ;; First call - cache matches, no update - (let ((cj/-cursor-last-color "#ffffff") - (cj/-cursor-last-buffer (buffer-name))) - (cj/set-cursor-color-according-to-mode) - (should (= call-count 0))) ; Cached, no update needed - - ;; Modify buffer and clear cache - should update - (insert "test") - (let ((cj/-cursor-last-buffer nil)) ; Force update - (cj/set-cursor-color-according-to-mode) - (should (= call-count 1))))) ; New state, should update - (advice-remove 'set-cursor-color advice-fn) - (kill-buffer normal-buf)))) - -(ert-deftest test-cursor-color-integration-different-buffers-different-colors () - "Test that switching between buffers with different states updates cursor." - (let ((buf1 (generate-new-buffer "test1")) - (buf2 (generate-new-buffer "test2")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (progn - ;; Set buf1 to read-only - (with-current-buffer buf1 - (setq buffer-read-only t) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#f06a3f"))) ; Red - - ;; Set buf2 to normal - (with-current-buffer buf2 - (setq buffer-read-only nil) - (set-buffer-modified-p nil) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#ffffff")))) ; White - (kill-buffer buf1) - (kill-buffer buf2)))) - -(ert-deftest test-cursor-color-integration-buffer-modification-changes-color () - "Test that modifying a buffer changes cursor from white to green." - (let ((normal-buf (generate-new-buffer "test-mod")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (with-current-buffer normal-buf - ;; Start unmodified - (set-buffer-modified-p nil) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#ffffff")) ; White - - ;; Modify buffer - (insert "test") - (should (buffer-modified-p)) - ;; Reset last buffer to force update - (setq cj/-cursor-last-buffer nil) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#64aa0f"))) ; Green - (kill-buffer normal-buf)))) - -(ert-deftest test-cursor-color-integration-save-changes-color-back () - "Test that saving a modified buffer changes cursor from green to white." - (let ((test-file (make-temp-file "test-cursor-")) - (cj/-cursor-last-color nil) - (cj/-cursor-last-buffer nil)) - (unwind-protect - (progn - ;; Create and modify file - (with-current-buffer (find-file-noselect test-file) - (insert "test") - (should (buffer-modified-p)) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#64aa0f")) ; Green - - ;; Save file - (save-buffer) - (should-not (buffer-modified-p)) - (cj/set-cursor-color-according-to-mode) - (should (equal cj/-cursor-last-color "#ffffff")) ; White - (kill-buffer))) - (delete-file test-file)))) - -;;; Performance Tests - -(ert-deftest test-cursor-color-integration-multiple-calls-efficient () - "Test that multiple rapid calls don't cause performance issues." - (with-temp-buffer - (let ((start-time (current-time))) - ;; Call 1000 times - (dotimes (_ 1000) - (cj/set-cursor-color-according-to-mode)) - (let ((elapsed (float-time (time-subtract (current-time) start-time)))) - ;; Should complete in less than 1 second (cache makes this very fast) - (should (< elapsed 1.0)))))) - -(provide 'test-ui-cursor-color-integration) -;;; test-ui-cursor-color-integration.el ends here diff --git a/tests/test-ui-navigation--split-dashboard.el b/tests/test-ui-navigation--split-dashboard.el new file mode 100644 index 000000000..407335f80 --- /dev/null +++ b/tests/test-ui-navigation--split-dashboard.el @@ -0,0 +1,90 @@ +;;; test-ui-navigation--split-dashboard.el --- Tests for split-with-dashboard -*- lexical-binding: t; -*- + +;;; Commentary: +;; C-x 2 / C-x 3 split and show the *dashboard* in the new window while point +;; stays in the original. cj/--split-show-buffer does the placement; +;; cj/split-below/right-with-dashboard wire it to the two split directions. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ui-navigation) + +(ert-deftest test-ui-navigation-split-dashboard-keybindings () + "Normal: C-x 2 / C-x 3 are bound to the dashboard-split commands." + (should (eq (key-binding (kbd "C-x 2")) #'cj/split-below-with-dashboard)) + (should (eq (key-binding (kbd "C-x 3")) #'cj/split-right-with-dashboard))) + +(ert-deftest test-ui-navigation-split-show-buffer-displays-and-keeps-point () + "Normal: the new window shows the buffer; the original stays selected." + (let ((buf (get-buffer-create " *split-dash-test*")) + (config (current-window-configuration))) + (unwind-protect + (progn + (delete-other-windows) + (let* ((orig (selected-window)) + (new (cj/--split-show-buffer #'split-window-below buf))) + (should (window-live-p new)) + (should (not (eq new orig))) + (should (eq (window-buffer new) buf)) + (should (eq (selected-window) orig)))) ; point stays put + (set-window-configuration config) + (kill-buffer buf)))) + +(ert-deftest test-ui-navigation-split-below-routes-to-split-window-below () + "Normal: cj/split-below-with-dashboard splits below with the dashboard buffer." + (let (captured) + (cl-letf (((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard)) + ((symbol-function 'cj/--split-show-buffer) + (lambda (fn buf) (setq captured (list fn buf)) nil))) + (cj/split-below-with-dashboard)) + (should (eq (car captured) #'split-window-below)) + (should (eq (cadr captured) 'dashboard)))) + +(ert-deftest test-ui-navigation-split-right-routes-to-split-window-right () + "Normal: cj/split-right-with-dashboard splits right with the dashboard buffer." + (let (captured) + (cl-letf (((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard)) + ((symbol-function 'cj/--split-show-buffer) + (lambda (fn buf) (setq captured (list fn buf)) nil))) + (cj/split-right-with-dashboard)) + (should (eq (car captured) #'split-window-right)) + (should (eq (cadr captured) 'dashboard)))) + +(ert-deftest test-ui-navigation-split-from-dashboard-p () + "Normal/Boundary: only the dashboard buffer routes the companion to *scratch*." + (should (cj/--split-from-dashboard-p "*dashboard*")) + (should-not (cj/--split-from-dashboard-p "todo.org")) + (should-not (cj/--split-from-dashboard-p "*scratch*"))) + +(ert-deftest test-ui-navigation-split-companion-scratch-from-dashboard () + "Normal: splitting from the dashboard yields the *scratch* buffer, not the +dashboard again." + (cl-letf (((symbol-function 'cj/--split-from-dashboard-p) (lambda (_) t)) + ((symbol-function 'get-scratch-buffer-create) (lambda () 'scratch)) + ((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard))) + (should (eq (cj/--split-companion-buffer) 'scratch)))) + +(ert-deftest test-ui-navigation-split-companion-dashboard-otherwise () + "Normal: splitting from any other buffer yields the dashboard." + (cl-letf (((symbol-function 'cj/--split-from-dashboard-p) (lambda (_) nil)) + ((symbol-function 'get-scratch-buffer-create) (lambda () 'scratch)) + ((symbol-function 'cj/--dashboard-buffer) (lambda () 'dashboard))) + (should (eq (cj/--split-companion-buffer) 'dashboard)))) + +(ert-deftest test-ui-navigation-dashboard-buffer-returns-existing () + "Boundary: cj/--dashboard-buffer returns an existing *dashboard* without opening." + (let ((db (get-buffer-create "*dashboard*")) + (opened nil)) + (unwind-protect + (cl-letf (((symbol-function 'dashboard-open) + (lambda (&rest _) (setq opened t)))) + (should (eq (cj/--dashboard-buffer) db)) + (should-not opened)) + (kill-buffer db)))) + +(provide 'test-ui-navigation--split-dashboard) +;;; test-ui-navigation--split-dashboard.el ends here diff --git a/tests/test-ui-navigation--window-resize.el b/tests/test-ui-navigation--window-resize.el index 3be0313b8..553219755 100644 --- a/tests/test-ui-navigation--window-resize.el +++ b/tests/test-ui-navigation--window-resize.el @@ -24,8 +24,11 @@ (should (eq (keymap-lookup cj/window-resize-map "<down>") #'windsize-down))) (ert-deftest test-ui-navigation-window-resize-sticky-dispatches-and-arms () - "Normal: `cj/window-resize-sticky' runs the `windsize' command matching the -arrow key that triggered it, then arms the sticky-repeat map." + "Normal: with more than one window, `cj/window-resize-sticky' runs the +`windsize' command matching the arrow key that triggered it, then arms the +sticky-repeat map. `one-window-p' is forced nil so the resize path is taken +deterministically -- in `--batch' the sole frame is one-window-p, which would +otherwise route to the pull-away path." (dolist (case '((left . windsize-left) (right . windsize-right) (up . windsize-up) @@ -33,13 +36,45 @@ arrow key that triggered it, then arms the sticky-repeat map." (let ((ran nil) (overriding-terminal-local-map nil) (pre-command-hook nil)) - (cl-letf (((symbol-function (cdr case)) + (cl-letf (((symbol-function 'one-window-p) (lambda (&rest _) nil)) + ((symbol-function (cdr case)) (lambda (&rest _) (interactive) (setq ran t)))) (let ((last-command-event (car case))) (cj/window-resize-sticky))) (should ran) ; dispatched to the right command (should overriding-terminal-local-map)))) ; loop armed +(ert-deftest test-ui-navigation-window-pull-side () + "Normal/Error: each arrow maps to the *opposite* side (where the revealed +window opens, so the current window keeps the arrow's edge); anything else +is nil." + (should (eq (cj/window-pull-side "<down>") 'above)) + (should (eq (cj/window-pull-side "<up>") 'below)) + (should (eq (cj/window-pull-side "<left>") 'right)) + (should (eq (cj/window-pull-side "<right>") 'left)) + (should (null (cj/window-pull-side "<prior>"))) + (should (null (cj/window-pull-side "x")))) + +(ert-deftest test-ui-navigation-window-resize-sticky-sole-window-pulls-away () + "Normal: with a single window, the arrow pulls a sliver away on the side +opposite the arrow (via `cj/window--pull-away') rather than resizing, then +arms the loop. `cj/window--pull-away' is stubbed to capture the side so no +real window split happens under `--batch'." + (dolist (case '((down . above) + (up . below) + (left . right) + (right . left))) + (let ((pulled nil) + (overriding-terminal-local-map nil) + (pre-command-hook nil)) + (cl-letf (((symbol-function 'one-window-p) (lambda (&rest _) t)) + ((symbol-function 'cj/window--pull-away) + (lambda (dir) (setq pulled dir)))) + (let ((last-command-event (car case))) + (cj/window-resize-sticky))) + (should (eq pulled (cdr case))) ; pulled toward the arrow + (should overriding-terminal-local-map)))) ; loop armed + (ert-deftest test-ui-navigation-window-resize-bound-under-c-semicolon-b () "Normal: `C-; b <arrow>' (each direction) reaches the sticky-resize command." (require 'custom-buffer-file) diff --git a/tests/test-ui-navigation-split-follow-undo-kill.el b/tests/test-ui-navigation-split-follow-undo-kill.el index 74c1e2fc1..35ed7a020 100644 --- a/tests/test-ui-navigation-split-follow-undo-kill.el +++ b/tests/test-ui-navigation-split-follow-undo-kill.el @@ -54,8 +54,9 @@ ;;; cj/undo-kill-buffer -(ert-deftest test-ui-navigation-undo-kill-buffer-opens-most-recent () - "Normal: with no arg, opens the head of recentf-list that isn't currently visited." +(ert-deftest test-ui-navigation-undo-kill-buffer-no-prefix-opens-most-recent () + "Normal: no prefix (arg=1, the value `\"p\"' yields) opens the most-recent +non-visited entry, not the second." (let ((opened nil) (recentf-mode t) (recentf-list '("/tmp/dead.org" "/tmp/alive.txt"))) @@ -69,14 +70,37 @@ (setq buffer-file-name "/tmp/alive.txt")) b)))) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (unwind-protect - (cj/undo-kill-buffer 0) + (cj/undo-kill-buffer 1) (when (get-buffer "*test-alive*") (kill-buffer "*test-alive*")))) (should (equal opened "/tmp/dead.org")))) -(ert-deftest test-ui-navigation-undo-kill-buffer-honors-numeric-arg () - "Normal: with N=1, opens the second non-visited entry from recentf-list." +(ert-deftest test-ui-navigation-undo-kill-buffer-skips-open-file-at-head () + "Boundary: an open file at the head of the list is skipped (equal, not eq). +The previous delq compared expand-file-name strings by identity, so a +currently-open most-recent file was never skipped." + (let ((opened nil) + (recentf-mode t) + ;; The open file is FIRST — only an equal-based filter removes it. + (recentf-list '("/tmp/alive.txt" "/tmp/dead.org"))) + (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) + ((symbol-function 'recentf-mode) (lambda (&rest _) t)) + ((symbol-function 'buffer-list) + (lambda (&rest _) + (list (let ((b (get-buffer-create "*test-alive*"))) + (with-current-buffer b + (setq buffer-file-name "/tmp/alive.txt")) + b)))) + ((symbol-function 'find-file) + (lambda (f &rest _) (setq opened f)))) + (unwind-protect + (cj/undo-kill-buffer 1) + (when (get-buffer "*test-alive*") (kill-buffer "*test-alive*")))) + (should (equal opened "/tmp/dead.org")))) + +(ert-deftest test-ui-navigation-undo-kill-buffer-numeric-arg-is-one-based () + "Normal: a numeric prefix is 1-based — N=2 opens the second non-visited entry." (let ((opened nil) (recentf-mode t) (recentf-list '("/tmp/a.org" "/tmp/b.org" "/tmp/c.org"))) @@ -84,11 +108,8 @@ ((symbol-function 'recentf-mode) (lambda (&rest _) t)) ((symbol-function 'buffer-list) (lambda (&rest _) nil)) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) - ;; cj/undo-kill-buffer takes a prefix `arg' and indexes into the list - ;; with `(nth arg ...)` when arg is non-nil. Passing 1 grabs the 2nd - ;; entry. - (cj/undo-kill-buffer 1)) + (lambda (f &rest _) (setq opened f)))) + (cj/undo-kill-buffer 2)) (should (equal opened "/tmp/b.org")))) (ert-deftest test-ui-navigation-undo-kill-buffer-no-op-when-list-empty () @@ -100,9 +121,22 @@ ((symbol-function 'recentf-mode) (lambda (&rest _) t)) ((symbol-function 'buffer-list) (lambda (&rest _) nil)) ((symbol-function 'find-file) - (lambda (f) (setq opened f)))) + (lambda (f &rest _) (setq opened f)))) (cj/undo-kill-buffer 0)) (should-not opened))) +(ert-deftest test-ui-navigation-undo-kill-buffer-out-of-range-arg-errors () + "Error: a prefix larger than the killed-file list signals a clear user-error, +not a wrong-type-argument from find-file on nil." + (let ((opened nil) + (recentf-mode t) + (recentf-list '("/tmp/a.org"))) + (cl-letf (((symbol-function 'require) (lambda (&rest _) t)) + ((symbol-function 'recentf-mode) (lambda (&rest _) t)) + ((symbol-function 'buffer-list) (lambda (&rest _) nil)) + ((symbol-function 'find-file) (lambda (f &rest _) (setq opened f)))) + (should-error (cj/undo-kill-buffer 5) :type 'user-error)) + (should-not opened))) + (provide 'test-ui-navigation-split-follow-undo-kill) ;;; test-ui-navigation-split-follow-undo-kill.el ends here diff --git a/tests/test-ui-theme-commands.el b/tests/test-ui-theme-commands.el index 55facc17e..1b273cf57 100644 --- a/tests/test-ui-theme-commands.el +++ b/tests/test-ui-theme-commands.el @@ -7,7 +7,6 @@ ;; cj/switch-themes ;; cj/save-theme-to-file ;; cj/get-active-theme-name -;; cj/load-fallback-theme ;;; Code: @@ -36,13 +35,11 @@ ;;; fallback-theme-name default -(ert-deftest test-ui-theme-default-fallback-is-bundled-dupre () - "Normal: the default fallback theme is dupre, the config's bundled theme. -modus-vivendi ships with Emacs but has no chosen dimming colors; dupre is -bundled in themes/, so it is available on every machine that loads this -config and is the right default fallback. Its loadability is covered by -test-dupre-theme.el." - (should (equal "dupre" (default-value 'fallback-theme-name)))) +(ert-deftest test-ui-theme-default-fallback-is-builtin-modus () + "Normal: the default fallback theme is modus-vivendi. +The fallback has no further fallback, so it must be present everywhere this +config loads. modus-vivendi ships with Emacs, so it always resolves." + (should (equal "modus-vivendi" (default-value 'fallback-theme-name)))) ;;; cj/save-theme-to-file @@ -70,23 +67,6 @@ does not raise." (cj/save-theme-to-file)) (should (string-match-p "Cannot save theme" messaged)))) -;;; cj/load-fallback-theme - -(ert-deftest test-ui-theme-load-fallback-disables-then-loads () - "Normal: load-fallback-theme disables all then loads the fallback." - (let ((fallback-theme-name "modus-vivendi") - (custom-enabled-themes '(old-one old-two)) - disabled loaded) - (cl-letf (((symbol-function 'disable-theme) - (lambda (theme) (push theme disabled))) - ((symbol-function 'load-theme) - (lambda (theme &optional _no-confirm _no-enable) - (push theme loaded))) - ((symbol-function 'message) #'ignore)) - (cj/load-fallback-theme "boom")) - (should (equal (sort (copy-sequence disabled) #'string<) '(old-one old-two))) - (should (equal loaded '(modus-vivendi))))) - ;;; cj/switch-themes (ert-deftest test-ui-theme-switch-disables-loads-then-saves () diff --git a/tests/test-ui-theme-persistence.el b/tests/test-ui-theme-persistence.el index 31e0e6cc8..02bb105a6 100644 --- a/tests/test-ui-theme-persistence.el +++ b/tests/test-ui-theme-persistence.el @@ -46,12 +46,12 @@ (lambda (&rest _args) (setq write-file-called t) (error "write-file should not be used")))) - (should (cj/theme-write-file-contents "dupre" file))) + (should (cj/theme-write-file-contents "modus-vivendi" file))) (delete-file file)) (should (equal (list (car write-region-args) (cadr write-region-args) (nth 2 write-region-args)) - (list "dupre" nil file))) + (list "modus-vivendi" nil file))) (should-not write-file-called))) (ert-deftest test-ui-theme-load-valid-persisted-theme () diff --git a/tests/test-update-text-file.el b/tests/test-update-text-file.el deleted file mode 100644 index fc4f8c36a..000000000 --- a/tests/test-update-text-file.el +++ /dev/null @@ -1,473 +0,0 @@ -;;; test-update-text-file.el --- Tests for update_text_file gptel tool -*- lexical-binding: t; -*- - -;;; Commentary: -;; Normal / Boundary / Error tests for each operation in -;; gptel-tools/update_text_file.el, plus file-level wrapper tests. -;; The pure-string helpers carry most of the coverage; the wrapper -;; only adds the I/O surface (backup, write, validation). - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) - (add-to-list 'load-path (expand-file-name "gptel-tools" user-emacs-directory)) - (setq load-prefer-newer t) - ;; Stub gptel so the tool file can be loaded without the real package. - (unless (featurep 'gptel) - (defvar gptel-tools nil) - (defun gptel-make-tool (&rest _args) nil) - (defun gptel-get-tool (&rest _args) nil) - (provide 'gptel))) - -(require 'update_text_file) - -;; ----------------------------------------------------- helpers - -(defun test-update-text-file--with-temp (content fn) - "Write CONTENT to a temp file, call FN with its path, then delete." - (let ((path (make-temp-file "test-update-text-file-"))) - (unwind-protect - (progn - (with-temp-file path (insert content)) - (funcall fn path)) - (when (file-exists-p path) (delete-file path))))) - -;; ----------------------------------------------------- replace - -(ert-deftest test-update-text-file-replace-normal () - "Normal: replace all occurrences of the literal pattern." - (should (equal (cj/update-text-file--replace "foo bar foo" "foo" "BAZ") - "BAZ bar BAZ"))) - -(ert-deftest test-update-text-file-replace-boundary-no-match () - "Boundary: pattern absent returns content unchanged." - (should (equal (cj/update-text-file--replace "abc" "xyz" "QQ") "abc"))) - -(ert-deftest test-update-text-file-replace-boundary-special-chars () - "Boundary: regex metacharacters in pattern are treated as literals." - (should (equal (cj/update-text-file--replace "a.b.c" "." "-") "a-b-c")) - (should (equal (cj/update-text-file--replace "(x)(y)" "(x)" "_") "_(y)")) - (should (equal (cj/update-text-file--replace "a$b" "$" "S") "aSb"))) - -(ert-deftest test-update-text-file-replace-boundary-unicode () - "Boundary: unicode in both pattern and replacement." - (should (equal (cj/update-text-file--replace "café résumé" "café" "thé") - "thé résumé"))) - -(ert-deftest test-update-text-file-replace-boundary-replacement-with-backref-like () - "Boundary: replacement strings with \\1 etc. are literal, not back-refs." - (should (equal (cj/update-text-file--replace "foo" "foo" "\\1bar") - "\\1bar"))) - -(ert-deftest test-update-text-file-replace-error-empty-pattern () - "Error: empty pattern signals." - (should-error (cj/update-text-file--replace "abc" "" "x"))) - -(ert-deftest test-update-text-file-replace-error-nil-pattern () - "Error: nil pattern signals." - (should-error (cj/update-text-file--replace "abc" nil "x"))) - -(ert-deftest test-update-text-file-replace-error-nil-replacement () - "Error: nil replacement signals." - (should-error (cj/update-text-file--replace "abc" "a" nil))) - -;; ----------------------------------------------------- append - -(ert-deftest test-update-text-file-append-normal () - "Normal: append adds text plus a trailing newline." - (should (equal (cj/update-text-file--append "line1\n" "line2") - "line1\nline2\n"))) - -(ert-deftest test-update-text-file-append-boundary-no-trailing-newline () - "Boundary: appends still produce a newline when content has none." - (should (equal (cj/update-text-file--append "abc" "def") - "abc\ndef\n"))) - -(ert-deftest test-update-text-file-append-boundary-empty-content () - "Boundary: appending to empty content yields just the new text + newline." - (should (equal (cj/update-text-file--append "" "hello") "hello\n"))) - -(ert-deftest test-update-text-file-append-boundary-text-with-trailing-newline () - "Boundary: text that already ends in newline isn't duplicated." - (should (equal (cj/update-text-file--append "a\n" "b\n") "a\nb\n"))) - -(ert-deftest test-update-text-file-append-error-empty-text () - "Error: empty text signals." - (should-error (cj/update-text-file--append "foo" ""))) - -(ert-deftest test-update-text-file-append-error-nil-text () - "Error: nil text signals." - (should-error (cj/update-text-file--append "foo" nil))) - -;; ----------------------------------------------------- prepend - -(ert-deftest test-update-text-file-prepend-normal () - "Normal: prepend adds text plus a separator newline." - (should (equal (cj/update-text-file--prepend "line1\n" "line0") - "line0\nline1\n"))) - -(ert-deftest test-update-text-file-prepend-boundary-empty-content () - "Boundary: prepending to empty content keeps just the new text + sep." - (should (equal (cj/update-text-file--prepend "" "hello") "hello\n"))) - -(ert-deftest test-update-text-file-prepend-boundary-text-with-trailing-newline () - "Boundary: text already terminated by newline is not double-broken." - (should (equal (cj/update-text-file--prepend "rest" "first\n") - "first\nrest"))) - -(ert-deftest test-update-text-file-prepend-error-empty-text () - "Error: empty text signals." - (should-error (cj/update-text-file--prepend "foo" ""))) - -(ert-deftest test-update-text-file-prepend-error-nil-text () - "Error: nil text signals." - (should-error (cj/update-text-file--prepend "foo" nil))) - -;; ----------------------------------------------------- insert-at-line - -(ert-deftest test-update-text-file-insert-at-line-normal () - "Normal: insert before line 2 of a 3-line file." - (should (equal (cj/update-text-file--insert-at-line "a\nb\nc\n" 2 "X") - "a\nX\nb\nc\n"))) - -(ert-deftest test-update-text-file-insert-at-line-boundary-first-line () - "Boundary: inserting at line 1 prepends." - (should (equal (cj/update-text-file--insert-at-line "a\nb\n" 1 "X") - "X\na\nb\n"))) - -(ert-deftest test-update-text-file-insert-at-line-boundary-one-past-end () - "Boundary: inserting one past the last line appends." - (should (equal (cj/update-text-file--insert-at-line "a\nb\n" 3 "X") - "a\nb\nX\n"))) - -(ert-deftest test-update-text-file-insert-at-line-boundary-no-trailing-newline () - "Boundary: works on content without a trailing newline." - (should (equal (cj/update-text-file--insert-at-line "a\nb" 2 "X") - "a\nX\nb"))) - -(ert-deftest test-update-text-file-insert-at-line-boundary-text-with-trailing-newline () - "Boundary: inserted text that ends in newline is not double-terminated." - (should (equal (cj/update-text-file--insert-at-line "a\nb\n" 2 "X\n") - "a\nX\nb\n"))) - -(ert-deftest test-update-text-file-insert-at-line-boundary-multiline-text () - "Boundary: multi-line inserted text is inserted as a block." - (should (equal (cj/update-text-file--insert-at-line "a\nb\n" 2 "X\nY") - "a\nX\nY\nb\n"))) - -(ert-deftest test-update-text-file-insert-at-line-boundary-empty-file-line-1 () - "Boundary: inserting at line 1 in an empty file works." - (should (equal (cj/update-text-file--insert-at-line "" 1 "X") - "X\n"))) - -(ert-deftest test-update-text-file-insert-at-line-error-empty-file-line-2 () - "Error: line 2 is out of range for an empty file." - (should-error (cj/update-text-file--insert-at-line "" 2 "X"))) - -(ert-deftest test-update-text-file-insert-at-line-error-out-of-range () - "Error: line number beyond file length signals." - (should-error (cj/update-text-file--insert-at-line "a\nb\n" 5 "X"))) - -(ert-deftest test-update-text-file-insert-at-line-error-zero () - "Error: line number 0 signals." - (should-error (cj/update-text-file--insert-at-line "a\n" 0 "X"))) - -(ert-deftest test-update-text-file-insert-at-line-error-negative () - "Error: negative line number signals." - (should-error (cj/update-text-file--insert-at-line "a\n" -1 "X"))) - -(ert-deftest test-update-text-file-insert-at-line-error-empty-text () - "Error: empty text signals." - (should-error (cj/update-text-file--insert-at-line "a\n" 1 ""))) - -;; ----------------------------------------------------- delete-lines - -(ert-deftest test-update-text-file-delete-lines-normal () - "Normal: removes lines containing the literal pattern." - (should (equal (cj/update-text-file--delete-lines "keep\nkill me\nkeep\n" "kill") - "keep\nkeep\n"))) - -(ert-deftest test-update-text-file-delete-lines-boundary-no-match () - "Boundary: pattern matches nothing returns content unchanged." - (should (equal (cj/update-text-file--delete-lines "a\nb\nc\n" "z") - "a\nb\nc\n"))) - -(ert-deftest test-update-text-file-delete-lines-boundary-all-lines-match () - "Boundary: every line removed yields the empty string." - (should (equal (cj/update-text-file--delete-lines "x\nx\nx\n" "x") ""))) - -(ert-deftest test-update-text-file-delete-lines-boundary-special-chars-literal () - "Boundary: regex metacharacters in pattern are treated as literals." - (should (equal (cj/update-text-file--delete-lines "a.b\naxb\n" ".") - "axb\n"))) - -(ert-deftest test-update-text-file-delete-lines-boundary-no-trailing-newline () - "Boundary: content without trailing newline keeps that shape." - (should (equal (cj/update-text-file--delete-lines "keep\ndrop" "drop") - "keep"))) - -(ert-deftest test-update-text-file-delete-lines-boundary-empty-file () - "Boundary: deleting from an empty file returns the empty string." - (should (equal (cj/update-text-file--delete-lines "" "anything") ""))) - -(ert-deftest test-update-text-file-delete-lines-boundary-backslash-literal () - "Boundary: backslashes in the pattern are literal." - (should (equal (cj/update-text-file--delete-lines "keep\npath\\name\n" "\\") - "keep\n"))) - -(ert-deftest test-update-text-file-delete-lines-error-empty-pattern () - "Error: empty pattern signals." - (should-error (cj/update-text-file--delete-lines "a\nb\n" ""))) - -(ert-deftest test-update-text-file-delete-lines-error-nil-pattern () - "Error: nil pattern signals." - (should-error (cj/update-text-file--delete-lines "a\nb\n" nil))) - -;; ----------------------------------------------------- apply-operation - -(ert-deftest test-update-text-file-apply-operation-dispatch () - "Each operation name dispatches to its transform." - (should (equal (cj/update-text-file--apply-operation "abc" "replace" "b" "B" nil) - "aBc")) - (should (equal (cj/update-text-file--apply-operation "a" "append" "b" nil nil) - "a\nb\n")) - (should (equal (cj/update-text-file--apply-operation "a" "prepend" "b" nil nil) - "b\na")) - (should (equal (cj/update-text-file--apply-operation "a\nb\n" "insert-at-line" "X" nil 2) - "a\nX\nb\n")) - (should (equal (cj/update-text-file--apply-operation "a\nb\n" "delete-lines" "a" nil nil) - "b\n"))) - -(ert-deftest test-update-text-file-apply-operation-error-unknown () - "Unknown operation signals." - (should-error (cj/update-text-file--apply-operation "x" "frobnicate" nil nil nil))) - -;; ----------------------------------------------------- validate-path - -(ert-deftest test-update-text-file-validate-path-normal () - "Normal: an existing readable+writable file under HOME passes." - (let* ((file (make-temp-file "test-update-text-file-"))) - (unwind-protect - (progn - ;; make-temp-file may land in /tmp; rebase to HOME for the test. - (let* ((home-file (expand-file-name - (concat ".test-update-text-file-" (format-time-string "%s") ".tmp") - "~"))) - (unwind-protect - (progn - (copy-file file home-file t) - (should (equal (cj/update-text-file--validate-path home-file) - (file-truename home-file)))) - (when (file-exists-p home-file) (delete-file home-file))))) - (when (file-exists-p file) (delete-file file))))) - -(ert-deftest test-update-text-file-validate-path-error-missing () - "Error: a missing file under HOME signals." - (let ((path (expand-file-name - (concat ".test-update-text-file-missing-" - (format-time-string "%s") ".tmp") - "~"))) - (when (file-exists-p path) (delete-file path)) - (should-error (cj/update-text-file--validate-path path)))) - -(ert-deftest test-update-text-file-validate-path-error-outside-home () - "Error: a path outside HOME signals." - (should-error (cj/update-text-file--validate-path "/etc/hostname"))) - -(ert-deftest test-update-text-file-validate-path-error-directory () - "Error: a directory signals." - (should-error (cj/update-text-file--validate-path "~"))) - -(ert-deftest test-update-text-file-validate-path-error-unreadable () - "Error: an unreadable file signals." - (test-update-text-file--in-home - "unreadable" "secret\n" - (lambda (path) - (cl-letf (((symbol-function 'file-readable-p) (lambda (_) nil))) - (should-error (cj/update-text-file--validate-path path)))))) - -(ert-deftest test-update-text-file-validate-path-error-unwritable () - "Error: an unwritable file signals." - (test-update-text-file--in-home - "unwritable" "locked\n" - (lambda (path) - (cl-letf (((symbol-function 'file-writable-p) (lambda (_) nil))) - (should-error (cj/update-text-file--validate-path path)))))) - -(ert-deftest test-update-text-file-validate-path-boundary-relative-home-path () - "Boundary: a relative path resolves under HOME." - (test-update-text-file--in-home - "relative" "ok\n" - (lambda (path) - (let ((relative (file-relative-name path (expand-file-name "~")))) - (should (equal (cj/update-text-file--validate-path relative) - (file-truename path))))))) - -(ert-deftest test-update-text-file-validate-path-boundary-symlink-inside-home () - "Boundary: a symlink inside HOME resolving inside HOME is accepted." - (test-update-text-file--in-home - "symlink-target" "ok\n" - (lambda (target) - (let ((link (expand-file-name - (format ".test-update-text-file-link-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link target link t) - (should (equal (cj/update-text-file--validate-path link) - (file-truename target)))) - (when (file-symlink-p link) (delete-file link))))))) - -(ert-deftest test-update-text-file-validate-path-error-symlink-outside-home () - "Error: a symlink inside HOME pointing outside HOME is rejected." - (let ((outside (make-temp-file "test-update-text-file-outside-")) - (link (expand-file-name - (format ".test-update-text-file-outside-link-%s.tmp" - (format-time-string "%s%N")) - "~"))) - (unwind-protect - (progn - (make-symbolic-link outside link t) - (should-error (cj/update-text-file--validate-path link))) - (when (file-exists-p outside) (delete-file outside)) - (when (file-symlink-p link) (delete-file link))))) - -;; ----------------------------------------------------- backup-name - -(ert-deftest test-update-text-file-backup-name-shape () - "Backup names append a timestamped .bak suffix." - (let ((name (cj/update-text-file--backup-name "/home/user/foo.txt"))) - (should (string-prefix-p "/home/user/foo.txt-" name)) - (should (string-suffix-p ".bak" name)) - ;; Format is YYYY-MM-DD-HHMMSS. - (should (string-match-p "-[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}-[0-9]\\{6\\}\\.bak\\'" - name)))) - -;; ----------------------------------------------------- file-level wrapper - -(defun test-update-text-file--in-home (suffix content fn) - "Write CONTENT to a temp file under HOME with SUFFIX, call FN, then delete. -Backups (path-TS.bak) are cleaned up after FN returns." - (let* ((name (format ".test-update-text-file-%s-%s.tmp" - suffix (format-time-string "%s%N"))) - (path (expand-file-name name "~"))) - (unwind-protect - (progn - (with-temp-file path (insert content)) - (funcall fn path)) - (when (file-exists-p path) (delete-file path)) - (dolist (b (file-expand-wildcards (concat path "-*.bak"))) - (when (file-exists-p b) (delete-file b)))))) - -(ert-deftest test-update-text-file-run-replace-normal () - "Wrapper: replace operation rewrites the file and creates a backup." - (test-update-text-file--in-home - "replace" "alpha bravo alpha\n" - (lambda (path) - (let ((result (cj/update-text-file--run path "replace" "alpha" "GAMMA" nil))) - (should (string-match-p "Updated" result)) - (should (string-match-p "backup:" result)) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "GAMMA bravo GAMMA\n"))) - (let ((backup (car (file-expand-wildcards (concat path "-*.bak"))))) - (should backup) - (with-temp-buffer - (insert-file-contents backup) - (should (equal (buffer-string) "alpha bravo alpha\n")))))))) - -(ert-deftest test-update-text-file-run-no-change-no-backup () - "Wrapper: no-op operation leaves the file untouched and creates no backup." - (test-update-text-file--in-home - "noop" "abc\n" - (lambda (path) - (let ((result (cj/update-text-file--run path "replace" "zzz" "QQ" nil))) - (should (string-match-p "No changes" result)) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "abc\n"))) - (should-not (file-expand-wildcards (concat path "-*.bak"))))))) - -(ert-deftest test-update-text-file-run-append-normal () - "Wrapper: append operation adds a line to the file." - (test-update-text-file--in-home - "append" "first\n" - (lambda (path) - (cj/update-text-file--run path "append" "second" nil nil) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "first\nsecond\n")))))) - -(ert-deftest test-update-text-file-run-insert-at-line-normal () - "Wrapper: insert-at-line inserts and rewrites the file." - (test-update-text-file--in-home - "insert" "a\nb\nc\n" - (lambda (path) - (cj/update-text-file--run path "insert-at-line" "X" nil 2) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "a\nX\nb\nc\n")))))) - -(ert-deftest test-update-text-file-run-delete-lines-normal () - "Wrapper: delete-lines removes matching lines." - (test-update-text-file--in-home - "delete" "keep1\nkill\nkeep2\nkill\n" - (lambda (path) - (cj/update-text-file--run path "delete-lines" "kill" nil nil) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "keep1\nkeep2\n")))))) - -(ert-deftest test-update-text-file-run-error-transform-leaves-file-unchanged () - "Wrapper: transform errors create no backup and leave the file unchanged." - (test-update-text-file--in-home - "transform-error" "abc\n" - (lambda (path) - (should-error (cj/update-text-file--run path "replace" "" "x" nil)) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "abc\n"))) - (should-not (file-expand-wildcards (concat path "-*.bak")))))) - -(ert-deftest test-update-text-file-run-error-unknown-operation-leaves-file-unchanged () - "Wrapper: unknown operations create no backup and leave the file unchanged." - (test-update-text-file--in-home - "unknown-operation" "abc\n" - (lambda (path) - (should-error (cj/update-text-file--run path "frobnicate" "x" nil nil)) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "abc\n"))) - (should-not (file-expand-wildcards (concat path "-*.bak")))))) - -(ert-deftest test-update-text-file-run-error-too-large-leaves-file-unchanged () - "Wrapper: the size guard errors before backup/write." - (test-update-text-file--in-home - "too-large" "abcdef\n" - (lambda (path) - (let ((cj/update-text-file--size-limit 3)) - (should-error (cj/update-text-file--run path "append" "x" nil nil))) - (with-temp-buffer - (insert-file-contents path) - (should (equal (buffer-string) "abcdef\n"))) - (should-not (file-expand-wildcards (concat path "-*.bak")))))) - -(ert-deftest test-update-text-file-run-error-missing-file () - "Wrapper: missing file signals." - (let ((path (expand-file-name - (concat ".test-update-text-file-absent-" - (format-time-string "%s") ".tmp") - "~"))) - (when (file-exists-p path) (delete-file path)) - (should-error (cj/update-text-file--run path "append" "x" nil nil)))) - -(ert-deftest test-update-text-file-run-error-outside-home () - "Wrapper: path outside home signals." - (should-error (cj/update-text-file--run "/etc/hostname" "append" "x" nil nil))) - -(provide 'test-update-text-file) -;;; test-update-text-file.el ends here diff --git a/tests/test-user-constants.el b/tests/test-user-constants.el index 8dd9284ff..0c12eecf4 100644 --- a/tests/test-user-constants.el +++ b/tests/test-user-constants.el @@ -120,5 +120,48 @@ The whole point of the split — a bare require must not touch the filesystem." (should (eq (nth 1 warn-args) :error))) (delete-directory dir t)))) +;;; verify-or-create no-op branches (target already present) + +(ert-deftest test-user-constants-verify-dir-existing-is-noop () + "Boundary: an existing directory is a no-op — make-directory is not called." + (test-user-constants--load) + (let ((dir (make-temp-file "uc-exdir-" t))) + (unwind-protect + (cl-letf (((symbol-function 'make-directory) + (lambda (&rest _) (error "should not create an existing dir")))) + (cj/verify-or-create-dir dir) ; must not error + (should (file-directory-p dir))) + (delete-directory dir t)))) + +(ert-deftest test-user-constants-verify-file-existing-is-noop () + "Boundary: an existing file is left untouched — write-region is not called." + (test-user-constants--load) + (let* ((dir (make-temp-file "uc-exfile-" t)) + (file (expand-file-name "keep.org" dir))) + (unwind-protect + (progn + (with-temp-file file (insert "original")) + (cl-letf (((symbol-function 'write-region) + (lambda (&rest _) (error "should not overwrite an existing file")))) + (cj/verify-or-create-file file) + (should (equal (with-temp-buffer + (insert-file-contents file) (buffer-string)) + "original")))) + (delete-directory dir t)))) + +(ert-deftest test-user-constants-verify-file-optional-failure-logs () + "Error: an optional file failure is logged, never warned or signalled." + (test-user-constants--load) + (let ((dir (make-temp-file "uc-optfile-" t)) + (warned nil) (messaged nil)) + (unwind-protect + (cl-letf (((symbol-function 'write-region) (lambda (&rest _) (error "boom"))) + ((symbol-function 'display-warning) (lambda (&rest _) (setq warned t))) + ((symbol-function 'message) (lambda (&rest _) (setq messaged t)))) + (cj/verify-or-create-file (expand-file-name "optional.org" dir)) + (should messaged) + (should-not warned)) + (delete-directory dir t)))) + (provide 'test-user-constants) ;;; test-user-constants.el ends here diff --git a/tests/test-video-audio-recording--build-video-command.el b/tests/test-video-audio-recording--build-video-command.el index 3b79c9ecb..4f2909784 100644 --- a/tests/test-video-audio-recording--build-video-command.el +++ b/tests/test-video-audio-recording--build-video-command.el @@ -21,7 +21,7 @@ "Wayland command pipes wf-recorder to ffmpeg." (let ((cj/recording-mic-boost 2.0) (cj/recording-system-volume 1.0)) - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) t))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) (let ((cmd (cj/recording--build-video-command "mic" "sys" "/tmp/out.mkv" t))) (should (string-match-p "wf-recorder.*|.*ffmpeg" cmd)) (should (string-match-p "-i pipe:0" cmd)) @@ -60,7 +60,7 @@ "Device names with special characters are shell-quoted in Wayland mode." (let ((cj/recording-mic-boost 1.0) (cj/recording-system-volume 1.0)) - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) t))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) (let ((cmd (cj/recording--build-video-command "device with spaces" "sys" "/tmp/out.mkv" t))) ;; shell-quote-argument escapes spaces with backslashes @@ -70,7 +70,7 @@ "Output filename with spaces is shell-quoted in Wayland mode." (let ((cj/recording-mic-boost 1.0) (cj/recording-system-volume 1.0)) - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) t))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) (let ((cmd (cj/recording--build-video-command "mic" "sys" "/tmp/my recording.mkv" t))) ;; Filename should be quoted/escaped @@ -103,7 +103,7 @@ (ert-deftest test-video-audio-recording--build-video-command-error-wayland-no-wf-recorder () "Wayland mode signals error when wf-recorder is not installed." - (cl-letf (((symbol-function 'executable-find) (lambda (_prog) nil))) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) nil))) (should-error (cj/recording--build-video-command "mic" "sys" "/tmp/out.mkv" t) :type 'user-error))) diff --git a/tests/test-video-audio-recording--test-device.el b/tests/test-video-audio-recording--test-device.el index e701b69fd..aa85b4388 100644 --- a/tests/test-video-audio-recording--test-device.el +++ b/tests/test-video-audio-recording--test-device.el @@ -20,7 +20,7 @@ "Runs exactly 2 shell commands: ffmpeg to record, ffplay to playback." (let ((commands nil)) (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording--test-device "test-device" "test-" "GO!") (should (= 2 (length commands))) ;; ffmpeg runs first (pushed last due to stack order) @@ -31,7 +31,7 @@ "The provided device name appears in the ffmpeg command." (let ((commands nil)) (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording--test-device "alsa_input.usb-Jabra.mono" "mic-" "SPEAK!") (let ((ffmpeg-cmd (cadr commands))) (should (string-match-p "alsa_input.usb-Jabra.mono" ffmpeg-cmd)) @@ -43,7 +43,7 @@ "Device names with special characters are shell-quoted." (let ((commands nil)) (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording--test-device "device with spaces" "test-" "GO!") (let ((ffmpeg-cmd (cadr commands))) ;; shell-quote-argument should have escaped the spaces @@ -54,7 +54,7 @@ (ert-deftest test-video-audio-recording--test-device-error-ffmpeg-failure-no-crash () "Function completes without error even when ffmpeg returns non-zero." (cl-letf (((symbol-function 'shell-command) - (lambda (_cmd) 1))) + (lambda (_cmd &rest _) 1))) ;; Should not signal any error (cj/recording--test-device "dev" "test-" "GO!") (should t))) diff --git a/tests/test-video-audio-recording-check-ffmpeg.el b/tests/test-video-audio-recording-check-ffmpeg.el index 5c264b640..1d8f13247 100644 --- a/tests/test-video-audio-recording-check-ffmpeg.el +++ b/tests/test-video-audio-recording-check-ffmpeg.el @@ -20,7 +20,7 @@ (ert-deftest test-video-audio-recording-check-ffmpeg-normal-ffmpeg-found-returns-t () "Test that function returns t when ffmpeg is found." (cl-letf (((symbol-function 'executable-find) - (lambda (cmd) + (lambda (cmd &rest _) (when (equal cmd "ffmpeg") "/usr/bin/ffmpeg")))) (let ((result (cj/recording-check-ffmpeg))) (should (eq t result))))) @@ -30,13 +30,13 @@ (ert-deftest test-video-audio-recording-check-ffmpeg-error-ffmpeg-not-found-signals-error () "Test that function signals user-error when ffmpeg is not found." (cl-letf (((symbol-function 'executable-find) - (lambda (_cmd) nil))) + (lambda (_cmd &rest _) nil))) (should-error (cj/recording-check-ffmpeg) :type 'user-error))) (ert-deftest test-video-audio-recording-check-ffmpeg-error-message-mentions-pacman () "Test that error message includes installation command." (cl-letf (((symbol-function 'executable-find) - (lambda (_cmd) nil))) + (lambda (_cmd &rest _) nil))) (condition-case err (cj/recording-check-ffmpeg) (user-error diff --git a/tests/test-video-audio-recording-ffmpeg-functions.el b/tests/test-video-audio-recording-ffmpeg-functions.el index 549aa317f..4b3570a26 100644 --- a/tests/test-video-audio-recording-ffmpeg-functions.el +++ b/tests/test-video-audio-recording-ffmpeg-functions.el @@ -190,7 +190,7 @@ (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) ((symbol-function 'signal-process) - (lambda (_pid _sig) (setq signal-called t) 0)) + (lambda (_pid _sig &rest _) (setq signal-called t) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/video-recording-stop) @@ -231,7 +231,7 @@ (signal-called nil)) (setq cj/audio-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'signal-process) - (lambda (_pid _sig) (setq signal-called t) 0)) + (lambda (_pid _sig &rest _) (setq signal-called t) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/audio-recording-stop) @@ -287,7 +287,7 @@ (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) ((symbol-function 'signal-process) - (lambda (_pid _sig) (error "Signal failed")))) + (lambda (_pid _sig &rest _) (error "Signal failed")))) (condition-case _err (cj/video-recording-stop) (error (setq error-raised t))) @@ -303,7 +303,7 @@ (error-raised nil)) (setq cj/audio-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'signal-process) - (lambda (_pid _sig) (error "Signal failed")))) + (lambda (_pid _sig &rest _) (error "Signal failed")))) (condition-case _err (cj/audio-recording-stop) (error (setq error-raised t))) diff --git a/tests/test-video-audio-recording-process-cleanup.el b/tests/test-video-audio-recording-process-cleanup.el index 52177a17c..7cb261c16 100644 --- a/tests/test-video-audio-recording-process-cleanup.el +++ b/tests/test-video-audio-recording-process-cleanup.el @@ -53,7 +53,7 @@ (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) ((symbol-function 'signal-process) - (lambda (pid sig) + (lambda (pid sig &rest _) (setq signaled-pid pid) (setq signaled-sig sig) 0)) @@ -85,7 +85,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (push (cons 'pkill args) call-order)) 0)) ((symbol-function 'signal-process) - (lambda (_pid _sig) + (lambda (_pid _sig &rest _) (push 'signal call-order) 0)) ((symbol-function 'cj/recording--wait-for-exit) @@ -114,7 +114,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (when (equal program "pkill") (push args pkill-args-list)) 0)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/video-recording-stop) @@ -140,7 +140,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (when (equal program "pkill") (setq pkill-called t)) 0)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) t))) (cj/video-recording-stop) @@ -206,7 +206,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (wait-timeout nil)) (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc timeout) (setq wait-called t) @@ -227,7 +227,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (warning-shown nil)) (setq cj/video-recording-ffmpeg-process fake-process) (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) - ((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + ((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) nil)) ; Simulate timeout ((symbol-function 'message) @@ -247,7 +247,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (let ((fake-process (make-process :name "test-audio" :command '("sleep" "1000"))) (warning-shown nil)) (setq cj/audio-recording-ffmpeg-process fake-process) - (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc _timeout) nil)) ; Simulate timeout ((symbol-function 'message) @@ -268,7 +268,7 @@ so ffmpeg sees EOF on its video input pipe and starts finalizing the file." (wait-called nil) (wait-timeout nil)) (setq cj/audio-recording-ffmpeg-process fake-process) - (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig) 0)) + (cl-letf (((symbol-function 'signal-process) (lambda (_pid _sig &rest _) 0)) ((symbol-function 'cj/recording--wait-for-exit) (lambda (_proc timeout) (setq wait-called t) diff --git a/tests/test-video-audio-recording-test-mic.el b/tests/test-video-audio-recording-test-mic.el index 60b9eb0b7..64ef0eaab 100644 --- a/tests/test-video-audio-recording-test-mic.el +++ b/tests/test-video-audio-recording-test-mic.el @@ -36,11 +36,11 @@ (let ((temp-file nil)) ;; Mock make-temp-file to capture filename (cl-letf (((symbol-function 'make-temp-file) - (lambda (prefix _dir-flag suffix) + (lambda (prefix _dir-flag suffix &rest _) (setq temp-file (concat prefix "12345" suffix)) temp-file)) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-mic) (should (string-match-p "\\.wav$" temp-file))))) (test-mic-teardown))) @@ -54,7 +54,7 @@ (let ((commands nil)) ;; Mock shell-command to capture all commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-mic) (should (= 2 (length commands))) ;; First command should be ffmpeg (stored last in list due to push) @@ -74,7 +74,7 @@ (let ((commands nil)) ;; Capture all shell commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-mic) (should (= 2 (length commands))) ;; Second command should be ffplay @@ -93,7 +93,7 @@ (cl-letf (((symbol-function 'message) (lambda (fmt &rest args) (push (apply #'format fmt args) messages))) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-mic) (should (>= (length messages) 3)) ;; Check for recording message @@ -135,7 +135,7 @@ (setq cj/recording-mic-device "test-mic-device") ;; Mock shell-command to fail (cl-letf (((symbol-function 'shell-command) - (lambda (_cmd) 1))) ;; Non-zero exit code + (lambda (_cmd &rest _) 1))) ;; Non-zero exit code ;; Should complete without crashing (ffmpeg errors are ignored) ;; No error is raised - function just completes (cj/recording-test-mic) diff --git a/tests/test-video-audio-recording-test-monitor.el b/tests/test-video-audio-recording-test-monitor.el index d821600f0..168e4f072 100644 --- a/tests/test-video-audio-recording-test-monitor.el +++ b/tests/test-video-audio-recording-test-monitor.el @@ -36,11 +36,11 @@ (let ((temp-file nil)) ;; Mock make-temp-file to capture filename (cl-letf (((symbol-function 'make-temp-file) - (lambda (prefix _dir-flag suffix) + (lambda (prefix _dir-flag suffix &rest _) (setq temp-file (concat prefix "12345" suffix)) temp-file)) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-monitor) (should (string-match-p "monitor-test-" temp-file)) (should (string-match-p "\\.wav$" temp-file))))) @@ -55,7 +55,7 @@ (let ((commands nil)) ;; Mock shell-command to capture all commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-monitor) (should (= 2 (length commands))) ;; First command should be ffmpeg (stored last in list due to push) @@ -75,7 +75,7 @@ (let ((commands nil)) ;; Capture all shell commands (cl-letf (((symbol-function 'shell-command) - (lambda (cmd) (push cmd commands) 0))) + (lambda (cmd &rest _) (push cmd commands) 0))) (cj/recording-test-monitor) (should (= 2 (length commands))) ;; Second command should be ffplay @@ -94,7 +94,7 @@ (cl-letf (((symbol-function 'message) (lambda (fmt &rest args) (push (apply #'format fmt args) messages))) ((symbol-function 'shell-command) - (lambda (_cmd) 0))) + (lambda (_cmd &rest _) 0))) (cj/recording-test-monitor) (should (>= (length messages) 3)) ;; Check for recording message @@ -136,7 +136,7 @@ (setq cj/recording-system-device "test-monitor-device") ;; Mock shell-command to fail (cl-letf (((symbol-function 'shell-command) - (lambda (_cmd) 1))) ;; Non-zero exit code + (lambda (_cmd &rest _) 1))) ;; Non-zero exit code ;; Should complete without crashing (ffmpeg errors are ignored) ;; No error is raised - function just completes (cj/recording-test-monitor) diff --git a/tests/test-video-audio-recording-toggle-functions.el b/tests/test-video-audio-recording-toggle-functions.el index 2355ab4f6..cdd3096ac 100644 --- a/tests/test-video-audio-recording-toggle-functions.el +++ b/tests/test-video-audio-recording-toggle-functions.el @@ -84,7 +84,7 @@ (let ((prompt-called nil) (recorded-dir nil)) (cl-letf (((symbol-function 'read-directory-name) - (lambda (_prompt) (setq prompt-called t) "/custom/path/")) + (lambda (_prompt &rest _) (setq prompt-called t) "/custom/path/")) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ; Directory exists ((symbol-function 'cj/ffmpeg-record-video) @@ -139,7 +139,7 @@ (let ((prompt-called nil) (recorded-dir nil)) (cl-letf (((symbol-function 'read-directory-name) - (lambda (_prompt) (setq prompt-called t) "/custom/path/")) + (lambda (_prompt &rest _) (setq prompt-called t) "/custom/path/")) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ; Directory exists ((symbol-function 'cj/ffmpeg-record-audio) diff --git a/tests/testutil-ai-config.el b/tests/testutil-ai-config.el deleted file mode 100644 index c74862226..000000000 --- a/tests/testutil-ai-config.el +++ /dev/null @@ -1,81 +0,0 @@ -;;; testutil-ai-config.el --- Test stubs for ai-config.el tests -*- lexical-binding: t; -*- - -;;; Commentary: -;; Provides gptel and dependency stubs so ai-config.el can be loaded in -;; batch mode without the real gptel package. Must be required BEFORE -;; ai-config so stubs are in place when use-package :config runs. - -;;; Code: - -(setq load-prefer-newer t) - -;; Keep ai-config tests isolated from personal optional GPTel tool files. -(defvar cj/gptel-tools-directory (make-temp-file "gptel-tools-empty-" t)) -(defvar cj/gptel-local-tool-features nil) - -;; Pre-cache API keys so auth-source is never consulted -(defvar cj/anthropic-api-key-cached "test-anthropic-key") -(defvar cj/openai-api-key-cached "test-openai-key") - -;; Stub gptel variables (must exist before use-package :custom runs) -(defvar gptel-backend nil) -(defvar gptel-model nil) -(defvar gptel-mode nil) -(defvar gptel-prompt-prefix-alist nil) -(defvar gptel--debug nil) -(defvar gptel-default-mode nil) -(defvar gptel-expert-commands nil) -(defvar gptel-track-media nil) -(defvar gptel-include-reasoning nil) -(defvar gptel-log-level nil) -(defvar gptel-confirm-tool-calls nil) -(defvar gptel-directives nil) -(defvar gptel--system-message nil) -(defvar gptel-context--alist nil) -(defvar gptel-mode-map (make-sparse-keymap)) -(defvar gptel-post-response-functions nil) - -;; Stub gptel functions -(defun gptel-make-anthropic (name &rest _args) - "Stub: return a vector mimicking a gptel backend struct." - (vector 'cl-struct-gptel-backend name)) - -(defun gptel-make-openai (name &rest _args) - "Stub: return a vector mimicking a gptel backend struct." - (vector 'cl-struct-gptel-backend name)) - -(defun gptel-send (&rest _) "Stub." nil) -(defun gptel-menu (&rest _) "Stub." nil) -(defun gptel (&rest _) "Stub." nil) -(defun gptel-system-prompt (&rest _) "Stub." nil) -(defun gptel-rewrite (&rest _) "Stub." nil) -(defun gptel-add-file (&rest _) "Stub." nil) -(defun gptel-add (&rest _) "Stub." nil) -(defun gptel-backend-models (_backend) "Stub." nil) - -(provide 'gptel) -(provide 'gptel-context) - -;; Stub custom keymap (defined in user's keybinding config) -(defvar cj/custom-keymap (make-sparse-keymap)) - -;; Stub which-key -(unless (fboundp 'which-key-add-key-based-replacements) - (defun which-key-add-key-based-replacements (&rest _) "Stub." nil)) -(provide 'which-key) - -;; Stub gptel-prompts -(defun gptel-prompts-update (&rest _) "Stub." nil) -(defun gptel-prompts-add-update-watchers (&rest _) "Stub." nil) -(provide 'gptel-prompts) - -;; NOTE: gptel-magit is NOT stubbed here. ai-config.el now uses -;; with-eval-after-load 'magit instead of use-package gptel-magit, -;; so the magit integration only activates when magit is provided. -;; See test-ai-config-gptel-magit-lazy-loading.el for magit stub tests. - -;; Stub ai-conversations -(provide 'ai-conversations) - -(provide 'testutil-ai-config) -;;; testutil-ai-config.el ends here diff --git a/tests/testutil-filesystem.el b/tests/testutil-filesystem.el deleted file mode 100644 index b1970b62d..000000000 --- a/tests/testutil-filesystem.el +++ /dev/null @@ -1,180 +0,0 @@ -;;; testutil-filesystem.el --- -*- coding: utf-8; lexical-binding: t; -*- -;; -;; Author: Craig Jennings <c@cjennings.net> -;; -;;; Commentary: -;; This library provides reusable helper functions for GPTel filesystem tools. -;; -;; It uses f.el and core Emacs libraries for path manipulation, directory listing, -;; file info retrieval, filtering, and recursive traversal. -;; -;; Designed to be used by multiple tools that operate on the filesystem. -;; -;;; Code: - -(require 'f) -(require 'cl-lib) -(require 'subr-x) - -;; Get directory entries in PATH. Returns list of absolute paths. -;; Default excludes hidden files and directories (name begins with dot). -;; Optional INCLUDE-HIDDEN to include hidden entries. -;; Optional FILTER-PREDICATE is a function called on each absolute path to filter. -(defun cj/get--directory-entries (path &optional include-hidden filter-predicate) - "Return a list of entries (absolute paths) in directory PATH. -Entries exclude '.' and '..'. -By default, hidden entries (starting with '.') are excluded unless -INCLUDE-HIDDEN is non-nil. FILTER-PREDICATE, if non-nil, is a predicate -function called on each entry's absolute path; only entries where it returns -non-nil are included." - ;; Convert 'path' to an absolute filename string - (let* ((expanded-path (expand-file-name path)) - ;; get absolute paths in expanded directory - (entries (directory-files expanded-path t nil t)) - ;; remove "." ".." entries - (filtered-entries - (cl-remove-if - (lambda (entry) - (or (member (f-filename entry) '("." "..")) - ;; and hidden files include-hidden is non-nil. - (and (not include-hidden) - (string-prefix-p "." (f-filename entry))))) - entries))) - ;; apply filtered predicate if provided - (if filter-predicate - (seq-filter filter-predicate filtered-entries) - ;; retun filtered-entries - filtered-entries))) - -(defun cj/get-file-info (path) - "Get file information for PATH. -Returned plist keys: -:success t or nil -:error string error message if :success is nil -:path absolute file path (string) -:size file size (integer) -:last-modified last modification time (time value) -:directory boolean: t if a directory -:permissions string with symbolic permissions, e.g. \"drwxr-xr-x\" -:executable boolean: t if executable file -:owner string: owner name or UID if name unavailable -:group string: group name or GID if name unavailable" - ;; handle errors during evaluation - (condition-case err - (let* ((expanded-path (expand-file-name path))) - (if (not (file-readable-p expanded-path)) - ;; Explicit permission denied check - (list :success nil :path expanded-path :error - (format "Permission denied: %s" expanded-path)) - (let* - ;; t = return string names for uid/gid - ((attrs (file-attributes expanded-path t)) - (size (file-attribute-size attrs)) - (mod (file-attribute-modification-time attrs)) - (dirp (eq t (file-attribute-type attrs))) - (modes (file-modes expanded-path)) - (perm (cj/-mode-to-permissions modes)) - (execp (file-executable-p expanded-path)) - (owner (file-attribute-user-id attrs)) ; Get owner - (group (file-attribute-group-id attrs))) ; Get group - (list :success t :path expanded-path :size size :last-modified mod - :directory dirp :permissions perm :executable execp - :owner (or owner "unknown") - :group (or group "unknown"))))) - ;; if error, return failure plist with error info - (error (list :success nil :path path :error (error-message-string err))))) - -(defun cj/format-file-info (file-info base-path) - "Format FILE-INFO plist relative to BASE-PATH as a string. -Handles missing keys gracefully by supplying default values." - (let ((permissions (or (plist-get file-info :permissions) "")) - (executable (if (plist-get file-info :executable) "*" " ")) - (size (file-size-human-readable (or (plist-get file-info :size) 0))) - (last-modified (or (plist-get file-info :last-modified) (current-time))) - (path (or (plist-get file-info :path) base-path))) - (format " %s%s %10s %s %s" - permissions - executable - size - (format-time-string "%Y-%m-%d %H:%M" last-modified) - (file-relative-name path base-path)))) - -;; Convert file mode bits integer to string like ls -l, e.g. drwxr-xr-x -(defun cj/-mode-to-permissions (mode) - "Convert file MODE (returned by `file-modes') to symbolic permission string." - (concat - (if (eq (logand #o40000 mode) #o40000) "d" "-") - (mapconcat - (lambda (bits) - (concat (if (/= 0 (logand bits 4)) "r" "-") - (if (/= 0 (logand bits 2)) "w" "-") - (if (/= 0 (logand bits 1)) "x" "-"))) - (list (logand (/ mode 64) 7) - (logand (/ mode 8) 7) - (logand mode 7)) - ""))) - -;; Filter a list of file info plists by extension (case insensitive). -;; Always includes directories. -(defun cj/filter-by-extension (file-info-list extension) - "Keep only directories and files with EXTENSION from FILE-INFO-LIST. -EXTENSION should not include leading dot, e.g. \"org\"." - ;; return full list if no extension - (if (not extension) - file-info-list - (cl-remove-if-not - (lambda (fi) - ;; always keep directories - (or (plist-get fi :directory) - ;; and successful file entries - (and (plist-get fi :success) - ;; and file extensions that match case-insensitively - (string-suffix-p (concat "." extension) - (f-filename (plist-get fi :path)) - t)))) - file-info-list))) - -(defun cj/list-directory-recursive (path &optional include-hidden filter-predicate max-depth) - "Recursively list files under PATH applying FILTER-PREDICATE. -PATH is the directory to list. -INCLUDE-HIDDEN if non-nil, includes hidden files (those starting with '.'). -FILTER-PREDICATE, if non-nil, is a function called on file info plist and -returns non-nil to include file. -MAX-DEPTH limits recursion depth (nil or 0 = unlimited)." - ;; set up cl-recursive function with path and current depth - (cl-labels ((recurse (path depth) - (let ((expanded-path (expand-file-name path)) - ;; empty list to accumulate file info plists - (file-info-list '())) - ;; ensure we're working with directories only - (when (not (file-directory-p expanded-path)) - (error "Not a directory: %s" expanded-path)) - - ;; loop over each file in the path - (dolist (file-entry - (cj/get--directory-entries expanded-path include-hidden)) - ;; get the metadata for the file - (let ((file-metadata (cj/get-file-info file-entry))) - ;; if retrieving metadata was successful - (when (and file-metadata (plist-get file-metadata :success)) - ;; if there's no custom filter or it matches, add it to the list - (when (or (not filter-predicate) - (funcall filter-predicate file-metadata)) - (push file-metadata file-info-list)) - ;; if it's a directory and we're not at the max-depth - (when (and (plist-get file-metadata :directory) - (or (not max-depth) (< depth (1- max-depth)))) - ;; gather all the files and recurse with that file - (setq file-info-list - (nconc file-info-list (recurse file-entry (1+ depth))))) - ;; warn if recursion returned received both a success and error - (when (and (plist-get file-metadata :success) - (plist-get file-metadata :error)) - (message "Warning: %s" (plist-get file-metadata :error)))))) - ;; restore the file order (as they were pushed into reverse order) - (nreverse file-info-list)))) - ;; start recursion at the top level - (recurse path 0))) - -(provide 'testutil-filesystem) -;;; testutil-filesystem.el ends here. diff --git a/tests/testutil-ghostel-buffers.el b/tests/testutil-ghostel-buffers.el index 52fb27e00..8e26efec4 100644 --- a/tests/testutil-ghostel-buffers.el +++ b/tests/testutil-ghostel-buffers.el @@ -45,5 +45,26 @@ ghostel-mode predicate without the side-effects of `(ghostel)'." (setq-local major-mode 'ghostel-mode)) buf)) +(defun cj/test--make-fake-eat-buffer (name) + "Return a buffer named NAME with `major-mode' set to `eat-mode'. + +Avoids actually launching an EAT process by setting the mode buffer-locally. +Used by the F12 toggle tests that need a buffer satisfying the eat-mode +predicate without the side-effects of `(eat)'." + (let ((buf (get-buffer-create name))) + (with-current-buffer buf + (setq-local major-mode 'eat-mode)) + buf)) + +(defun cj/test--make-fake-eshell-buffer (name) + "Return a buffer named NAME with `major-mode' set to `eshell-mode'. + +Avoids starting a real eshell by setting the mode buffer-locally. Used by the +F12 toggle tests that need a buffer satisfying the eshell-mode predicate." + (let ((buf (get-buffer-create name))) + (with-current-buffer buf + (setq-local major-mode 'eshell-mode)) + buf)) + (provide 'testutil-ghostel-buffers) ;;; testutil-ghostel-buffers.el ends here |