diff options
Diffstat (limited to 'tests')
99 files changed, 6175 insertions, 853 deletions
diff --git a/tests/test-agenda-query--bounds.el b/tests/test-agenda-query--bounds.el new file mode 100644 index 00000000..9ee423e7 --- /dev/null +++ b/tests/test-agenda-query--bounds.el @@ -0,0 +1,169 @@ +;;; test-agenda-query--bounds.el --- Tests for timestamp bounds -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/--agenda-query-timestamp-bounds', which turns an org-element +;; timestamp into epoch bounds for the JSON query. +;; +;; The contract under test: +;; - :start is the epoch of the timestamp's start. +;; - :end is the epoch of an explicit range end, or nil when the source has no +;; range. A null end is information the consumer cannot re-derive, so it is +;; never filled in with a guess. +;; - :all-day is t when the timestamp carries no hour. +;; - :effective-end is what the window predicate uses: the explicit end, or for +;; an all-day entry the end of its last day, or for a timed point event the +;; start itself. This is the "treat the day as its extent" rule, kept out of +;; :end so the reported shape stays faithful to the source. +;; +;; Helpers carry a file-unique prefix on purpose: the editor hook loads every +;; agenda-query test file into ONE process, so a shared helper name here would +;; silently redefine its namesake in a sibling file. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) + +(defun test-aq-bounds--epoch (sec min hour day month year) + "Return the epoch second for the local time SEC MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list sec min hour day month year nil -1 nil)) + 'integer)) + +(defun test-aq-bounds--of (raw) + "Parse timestamp string RAW and return its bounds plist." + (cj/--agenda-query-timestamp-bounds (org-timestamp-from-string raw))) + +;;; Normal Cases + +(ert-deftest test-agenda-query-bounds-normal-timed-range () + "Normal: a same-day timed range reports both ends and is not all-day." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 23:00-23:30>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 23 31 7 2026))) + (should (equal (plist-get b :end) + (test-aq-bounds--epoch 0 30 23 31 7 2026))) + (should-not (plist-get b :all-day)) + (should (equal (plist-get b :effective-end) (plist-get b :end))))) + +(ert-deftest test-agenda-query-bounds-normal-timed-point () + "Normal: a timed point event has no end, and its extent is the instant." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 14:00>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 14 31 7 2026))) + (should-not (plist-get b :end)) + (should-not (plist-get b :all-day)) + (should (equal (plist-get b :effective-end) (plist-get b :start))))) + +;;; Boundary Cases + +(ert-deftest test-agenda-query-bounds-boundary-all-day-extent () + "Boundary: an all-day entry reports no end but extends over its whole day." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 31 7 2026))) + (should-not (plist-get b :end)) + (should (plist-get b :all-day)) + ;; One second short of the next midnight -- the day is the extent. + (should (equal (plist-get b :effective-end) + (1- (test-aq-bounds--epoch 0 0 0 1 8 2026)))))) + +(ert-deftest test-agenda-query-bounds-boundary-multi-day-all-day () + "Boundary: a multi-day all-day range ends at the close of its last day." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri>--<2026-08-02 Sun>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 31 7 2026))) + (should (plist-get b :all-day)) + (should (equal (plist-get b :end) + (1- (test-aq-bounds--epoch 0 0 0 3 8 2026)))) + (should (equal (plist-get b :effective-end) (plist-get b :end))))) + +(ert-deftest test-agenda-query-bounds-boundary-midnight-start () + "Boundary: an explicit 00:00 is a timed event, not an all-day one." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 00:00>"))) + (should-not (plist-get b :all-day)) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 31 7 2026))))) + +(ert-deftest test-agenda-query-bounds-boundary-dst-spring-forward () + "Boundary: a timestamp on a DST changeover day still resolves to one epoch. +US DST began 2026-03-08. The interface is epoch seconds precisely so the +consumer never has to know the source timestamps are naive local time." + (let ((b (test-aq-bounds--of "<2026-03-08 Sun 13:00>"))) + (should (integerp (plist-get b :start))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 13 8 3 2026))))) + +(ert-deftest test-agenda-query-bounds-boundary-dst-day-is-23-hours () + "Boundary: the day-extent rule follows real clock time, not a fixed 86400. +2026-03-08 loses an hour, so its all-day extent is one second short of 23 +hours. Adding a constant day would overshoot into the next day." + (let ((b (test-aq-bounds--of "<2026-03-08 Sun>"))) + (should (equal (plist-get b :effective-end) + (1- (test-aq-bounds--epoch 0 0 0 9 3 2026)))) + (should (= (- (plist-get b :effective-end) (plist-get b :start)) + (1- (* 23 3600)))))) + +(ert-deftest test-agenda-query-bounds-boundary-same-day-range-crosses-midnight () + "Boundary: a range whose end precedes its start is read as crossing midnight. + +Org records <2026-07-31 Fri 23:00-01:00> with day-end EQUAL to day-start, so +reading it literally puts the end 22 hours before the start. A negative +duration is meaningless to a renderer, and the row would also vanish from the +very window it belongs to, since its effective end would sit before the +window opens." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 23:00-01:00>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 23 31 7 2026))) + (should (equal (plist-get b :end) + (test-aq-bounds--epoch 0 0 1 1 8 2026))) + (should (> (plist-get b :end) (plist-get b :start))) + (should (= (- (plist-get b :end) (plist-get b :start)) (* 2 3600))))) + +(ert-deftest test-agenda-query-bounds-boundary-reversed-multi-day-range () + "Boundary: a genuinely reversed multi-day range reports no end at all. + +The midnight roll is scoped to same-day ranges, which is the shape org uses +for <23:00-01:00>. Rolling a reversed multi-day range would shift a wrong +date by one day and leave it still wrong, so instead the entry is reported as +a point -- a consumer can draw that, where a negative-duration bar is +meaningless." + (let ((b (test-aq-bounds--of "<2026-08-02 Sun 09:00>--<2026-07-31 Fri 08:00>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 9 2 8 2026))) + (should-not (plist-get b :end)) + (should (equal (plist-get b :effective-end) (plist-get b :start))))) + +(ert-deftest test-agenda-query-bounds-boundary-reversed-all-day-range () + "Boundary: a reversed ALL-DAY range also reports no end. + +The same malformed shape as the timed case, and the same consequence if it +slips through: the negative extent would sit before the start, so the entry +would vanish from the very day it opens on. A typo or a bad ICS import +produces this." + (let ((b (test-aq-bounds--of "<2026-08-05 Wed>--<2026-08-01 Sat>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 5 8 2026))) + (should-not (plist-get b :end)) + ;; Falls back to its own day, so it still appears on 5 August. + (should (> (plist-get b :effective-end) (plist-get b :start))))) + +;;; Error Cases + +(ert-deftest test-agenda-query-bounds-error-inactive-still-computes () + "Error: bounds are purely arithmetic -- filtering inactive stamps is a +separate concern, so an inactive timestamp still yields usable bounds." + (let ((b (test-aq-bounds--of "[2026-07-31 Fri 09:00]"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 9 31 7 2026))))) + +(ert-deftest test-agenda-query-bounds-error-nil-timestamp () + "Error: a nil timestamp yields nil rather than signaling." + (should-not (cj/--agenda-query-timestamp-bounds nil))) + +(provide 'test-agenda-query--bounds) +;;; test-agenda-query--bounds.el ends here diff --git a/tests/test-agenda-query--occurrences.el b/tests/test-agenda-query--occurrences.el new file mode 100644 index 00000000..4fa73a0c --- /dev/null +++ b/tests/test-agenda-query--occurrences.el @@ -0,0 +1,242 @@ +;;; test-agenda-query--occurrences.el --- Tests for window + repeats -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/--agenda-query-occurrences' and the repeater cookie helper. +;; +;; Two behaviors under test: +;; +;; 1. The window predicate is intersection, not containment. An event running +;; across the window's start edge is in the window -- on a live surface it is +;; the thing currently happening. +;; +;; 2. A repeating entry contributes one row per occurrence inside the window, +;; expanded through org's own arithmetic. The base timestamp of a long-lived +;; repeater sits far in the past, so returning it raw would put a task that is +;; genuinely due today outside the window entirely. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) + +(defun test-agenda-query-occ--epoch (min hour day month year) + "Return the epoch for local MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list 0 min hour day month year nil -1 nil)) + 'integer)) + +(defun test-agenda-query-occ--of (raw start end) + "Return occurrences of timestamp string RAW within START..END." + (cj/--agenda-query-occurrences (org-timestamp-from-string raw) start end)) + +(defun test-agenda-query-occ--starts (raw start end) + "Return just the start epochs of RAW's occurrences within START..END." + (mapcar #'car (test-agenda-query-occ--of raw start end))) + +;;; ---------- repeater cookie ---------- + +(ert-deftest test-agenda-query-cookie-normal-all-three-styles () + "Normal: each repeater style round-trips to its raw cookie." + (should (equal "+1d" (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed +1d>")))) + (should (equal "++2w" (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed ++2w>")))) + (should (equal ".+3m" (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed .+3m>"))))) + +(ert-deftest test-agenda-query-cookie-boundary-none () + "Boundary: a plain timestamp has no cookie, and nil is not a cookie." + (should-not (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed>"))) + (should-not (cj/--agenda-query-repeater-cookie nil))) + +;;; ---------- window predicate ---------- + +(ert-deftest test-agenda-query-occ-normal-inside-window () + "Normal: an event wholly inside the window is returned once, with its end." + (let* ((win-start (test-agenda-query-occ--epoch 0 8 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 18 31 7 2026)) + (occ (test-agenda-query-occ--of "<2026-07-31 Fri 09:00-10:00>" + win-start win-end))) + (should (= 1 (length occ))) + (should (equal (caar occ) (test-agenda-query-occ--epoch 0 9 31 7 2026))) + (should (equal (cdar occ) (test-agenda-query-occ--epoch 0 10 31 7 2026))))) + +(ert-deftest test-agenda-query-occ-boundary-overlaps-start-edge () + "Boundary: an event that began before the window but is still running is in. +This is the 23:00-01:00 case -- the whole reason the predicate is intersects +rather than starts-inside." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 1 8 2026)) + (win-end (test-agenda-query-occ--epoch 0 23 1 8 2026))) + (should (= 1 (length (test-agenda-query-occ--of + "<2026-07-31 Fri 23:00>--<2026-08-01 Sat 01:00>" + win-start win-end)))))) + +(ert-deftest test-agenda-query-occ-boundary-touches-edge-exactly () + "Boundary: an event ending exactly at the window start is still included." + (let* ((win-start (test-agenda-query-occ--epoch 0 10 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 18 31 7 2026))) + (should (= 1 (length (test-agenda-query-occ--of + "<2026-07-31 Fri 09:00-10:00>" win-start win-end)))))) + +(ert-deftest test-agenda-query-occ-boundary-all-day-covers-window () + "Boundary: an all-day entry covers any window inside its day." + (let* ((win-start (test-agenda-query-occ--epoch 0 13 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 30 13 31 7 2026)) + (occ (test-agenda-query-occ--of "<2026-07-31 Fri>" win-start win-end))) + (should (= 1 (length occ))) + ;; No range in the source, so no end is invented. + (should-not (cdar occ)))) + +(ert-deftest test-agenda-query-occ-boundary-outside-window () + "Boundary: an event finishing before the window opens is excluded." + (let* ((win-start (test-agenda-query-occ--epoch 0 12 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 18 31 7 2026))) + (should-not (test-agenda-query-occ--of "<2026-07-31 Fri 09:00-10:00>" + win-start win-end)))) + +;;; ---------- repeat expansion ---------- + +(ert-deftest test-agenda-query-occ-normal-daily-repeat-reaches-today () + "Normal: a daily repeater based a month back yields today's occurrence. +Returning the raw base date would put a task genuinely due today far outside +the window -- this is the failure the expansion exists to prevent." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (starts (test-agenda-query-occ--starts "<2026-07-01 Wed 09:00 +1d>" + win-start win-end))) + (should (equal starts (list (test-agenda-query-occ--epoch 0 9 31 7 2026)))))) + +(ert-deftest test-agenda-query-occ-normal-repeat-preserves-duration () + "Normal: an expanded occurrence keeps the base timestamp's duration." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (occ (car (test-agenda-query-occ--of "<2026-07-01 Wed 09:00-10:30 +1d>" + win-start win-end)))) + (should occ) + (should (equal (car occ) (test-agenda-query-occ--epoch 0 9 31 7 2026))) + (should (equal (cdr occ) (test-agenda-query-occ--epoch 30 10 31 7 2026))))) + +(ert-deftest test-agenda-query-occ-boundary-one-row-per-occurrence () + "Boundary: a window wider than the interval yields a row per occurrence. +A count is derivable from rows; rows are not derivable from a count, so the +row form is what the query returns." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 27 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (starts (test-agenda-query-occ--starts "<2026-07-01 Wed 09:00 +1d>" + win-start win-end))) + (should (= 5 (length starts))) + (should (equal starts + (list (test-agenda-query-occ--epoch 0 9 27 7 2026) + (test-agenda-query-occ--epoch 0 9 28 7 2026) + (test-agenda-query-occ--epoch 0 9 29 7 2026) + (test-agenda-query-occ--epoch 0 9 30 7 2026) + (test-agenda-query-occ--epoch 0 9 31 7 2026)))))) + +(ert-deftest test-agenda-query-occ-boundary-weekly-lands-on-its-day () + "Boundary: a weekly repeater yields only the days it actually falls on. +2026-07-01 is a Wednesday, so within Mon 27 -- Fri 31 July only Wed 29 counts." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 27 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (starts (test-agenda-query-occ--starts "<2026-07-01 Wed 09:00 +1w>" + win-start win-end))) + (should (equal starts (list (test-agenda-query-occ--epoch 0 9 29 7 2026)))))) + +(ert-deftest test-agenda-query-occ-boundary-restart-style-expands () + "Boundary: a .+ repeater expands from its base like any other style. + +Org rewrites a restart repeater's base timestamp when the task is completed, +so for an open task the base IS the last repeat and base-relative expansion is +what the agenda shows. All three styles agree here." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (expected (list (test-agenda-query-occ--epoch 0 9 31 7 2026)))) + (dolist (raw '("<2026-07-01 Wed 09:00 +1d>" + "<2026-07-01 Wed 09:00 ++1d>" + "<2026-07-01 Wed 09:00 .+1d>")) + (should (equal expected + (test-agenda-query-occ--starts raw win-start win-end)))))) + +(ert-deftest test-agenda-query-occ-boundary-repeat-not-yet-started () + "Boundary: a repeater whose base is after the window yields nothing." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026))) + (should-not (test-agenda-query-occ--starts "<2026-12-01 Tue 09:00 +1d>" + win-start win-end)))) + +(ert-deftest test-agenda-query-occ-boundary-zero-value-repeater () + "Boundary: org treats a zero-value repeater as void, so it behaves as a +plain timestamp -- absent when its base is outside the window, and present +exactly once when the base is inside it. + +Both halves are asserted deliberately. The absent half alone would also pass +against an implementation with no repeater support at all, which makes it no +evidence about zero-value handling." + (should-not (test-agenda-query-occ--starts + "<2026-07-01 Wed 09:00 +0d>" + (test-agenda-query-occ--epoch 0 0 31 7 2026) + (test-agenda-query-occ--epoch 59 23 31 7 2026))) + (should (equal (list (test-agenda-query-occ--epoch 0 9 1 7 2026)) + (test-agenda-query-occ--starts + "<2026-07-01 Wed 09:00 +0d>" + (test-agenda-query-occ--epoch 0 0 1 7 2026) + (test-agenda-query-occ--epoch 59 23 1 7 2026))))) + +(ert-deftest test-agenda-query-occ-boundary-repeat-in-progress-at-window-start () + "Boundary: a repeating event that began before the window and is still +running is returned. + +The non-repeating path honors intersects-not-contains; the repeating path has +to as well. Scanning only days inside the window misses this, because the +occurrence's own day starts earlier: a nightly 22:00-02:00 job is the thing +actually happening at 03:00, and a renderer that drops it shows an empty slot +during the event." + (let ((raw "<2026-07-01 Wed 22:00 +1d>--<2026-07-02 Thu 02:00>")) + (should (= 1 (length (test-agenda-query-occ--of + raw + (test-agenda-query-occ--epoch 0 0 31 7 2026) + (test-agenda-query-occ--epoch 0 6 31 7 2026))))) + ;; The same occurrence seen from inside its own evening. + (should (= 1 (length (test-agenda-query-occ--of + raw + (test-agenda-query-occ--epoch 0 21 31 7 2026) + (test-agenda-query-occ--epoch 0 23 31 7 2026))))))) + +(ert-deftest test-agenda-query-occ-boundary-repeat-extent-follows-dst () + "Boundary: an all-day repeat's extent is recomputed per occurrence day. + +US DST ends 2026-11-01, making that day 25 hours long. Carrying the base +day's length forward as a fixed number of seconds leaves the occurrence +ending an hour early, so a window late on that day sees nothing while the +identical non-repeating entry is found." + (let ((win-start (test-agenda-query-occ--epoch 30 23 1 11 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 1 11 2026))) + (should (= 1 (length (test-agenda-query-occ--of "<2026-07-01 Wed +1d>" + win-start win-end)))) + ;; The non-repeating control: same day, same window, must agree. + (should (= 1 (length (test-agenda-query-occ--of "<2026-11-01 Sun>" + win-start win-end)))))) + +;;; ---------- error cases ---------- + +(ert-deftest test-agenda-query-occ-error-inverted-window () + "Error: a window whose start is after its end matches nothing. +Without the guard the intersection test passes for any long-running event, +which would silently return rows for a nonsense request." + (let* ((win-start (test-agenda-query-occ--epoch 0 18 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 8 31 7 2026))) + (should-not (test-agenda-query-occ--of "<2026-07-31 Fri 09:00-10:00>" + win-start win-end)) + (should-not (test-agenda-query-occ--of "<2026-07-01 Wed 09:00 +1d>" + win-start win-end)))) + +(ert-deftest test-agenda-query-occ-error-nil-timestamp () + "Error: a nil timestamp yields no occurrences rather than signaling." + (should-not (cj/--agenda-query-occurrences nil 0 100))) + +(provide 'test-agenda-query--occurrences) +;;; test-agenda-query--occurrences.el ends here diff --git a/tests/test-agenda-query--render.el b/tests/test-agenda-query--render.el new file mode 100644 index 00000000..48d28773 --- /dev/null +++ b/tests/test-agenda-query--render.el @@ -0,0 +1,275 @@ +;;; test-agenda-query--render.el --- Tests for the renderer profile -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/agenda-render-json' and the row transform behind it. +;; +;; The renderer reads three keys — s and e as epoch MILLISECONDS, t as the +;; title — and drops everything else before drawing. Two things therefore have +;; to hold, and both are asserted rather than assumed: +;; +;; 1. s and e really are milliseconds. A seconds-for-milliseconds slip puts +;; every bar in 1970 and the surface renders empty, which looks exactly like +;; "Emacs isn't writing the file". +;; 2. Every row has a drawable e. The canonical profile reports null where the +;; source has no range, and null is not a width. +;; +;; Helpers carry a file-unique prefix: the editor hook loads every +;; agenda-query test file into ONE process. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) +;; Supplies `cj/org-todo-keywords', the vocabulary the batch writer sets and +;; the editor's org config reads. +(require 'user-constants) + +(defun test-aq-render--epoch (min hour day month year) + "Return the epoch for local MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list 0 min hour day month year nil -1 nil)) + 'integer)) + +(defmacro test-aq-render--with-agenda-file (text &rest body) + "Write TEXT to a temp agenda file and run BODY with `rows' bound. +`rows' is the parsed render-profile output for all of 2026-07-31." + (declare (indent 1)) + `(let* ((dir (make-temp-file "agenda-render-" t)) + (file (expand-file-name "todo.org" dir))) + (unwind-protect + (progn + (with-temp-file file (insert ,text)) + (let* ((org-agenda-files (list file)) + (rows (append (json-parse-string + (cj/agenda-render-json + (test-aq-render--epoch 0 0 31 7 2026) + (test-aq-render--epoch 59 23 31 7 2026)) + :object-type 'alist) + nil))) + ,@body)) + (dolist (buffer (buffer-list)) + (when (equal (buffer-file-name buffer) file) (kill-buffer buffer))) + (delete-directory dir t)))) + +;;; Normal Cases + +(ert-deftest test-agenda-render-normal-emits-milliseconds () + "Normal: s and e are epoch milliseconds, not seconds. + +The renderer works in milliseconds throughout. Sending seconds puts every bar +in January 1970, which draws as an empty surface — indistinguishable from the +file never being written." + (test-aq-render--with-agenda-file + "* Standup\nSCHEDULED: <2026-07-31 Fri 09:00-09:30>\n" + (let ((row (car rows))) + (should (= (alist-get 's row) + (* 1000 (test-aq-render--epoch 0 9 31 7 2026)))) + (should (= (alist-get 'e row) + (* 1000 (test-aq-render--epoch 30 9 31 7 2026)))) + ;; Sanity on the magnitude: milliseconds since 1970 are 13 digits now. + (should (= 13 (length (number-to-string (alist-get 's row)))))))) + +(ert-deftest test-agenda-render-normal-title-is-t () + "Normal: the title is carried as t, the key the renderer reads." + (test-aq-render--with-agenda-file + "* TODO [#A] Standup with Nerses :work:\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "Standup with Nerses" (alist-get 't (car rows)))))) + +(ert-deftest test-agenda-render-normal-canonical-fields-survive () + "Normal: the canonical fields ride along, since the consumer drops its own. +One file serves both the renderer and anything reading the documented shape." + (test-aq-render--with-agenda-file + "* DONE Standup\nSCHEDULED: <2026-07-31 Fri 09:00-09:30>\n" + (let ((row (car rows))) + (should (equal "Standup" (alist-get 'title row))) + (should (eq t (alist-get 'done row))) + (should (equal "scheduled" (alist-get 'type row))) + ;; start stays SECONDS while s is milliseconds; the units never mix + ;; within a key. + (should (= (alist-get 'start row) (/ (alist-get 's row) 1000)))))) + +;;; Boundary Cases + +(ert-deftest test-agenda-render-boundary-all-day-spans-its-day () + "Boundary: an all-day entry gets a drawable e covering its whole day. +Canonically its end is null, and null is not something a renderer can draw." + (test-aq-render--with-agenda-file + "* TODO Water plants\nSCHEDULED: <2026-07-31 Fri>\n" + (let ((row (car rows))) + (should (eq :null (alist-get 'end row))) + (should (= (alist-get 's row) + (* 1000 (test-aq-render--epoch 0 0 31 7 2026)))) + (should (= (alist-get 'e row) + (* 1000 (1- (test-aq-render--epoch 0 0 1 8 2026)))))))) + +(ert-deftest test-agenda-render-boundary-point-event-has-zero-width () + "Boundary: a timed point event ends where it starts rather than at null. +Zero width is a marker the renderer can decide how to draw; null is a crash or +a silently dropped row." + (test-aq-render--with-agenda-file + "* Reminder\n<2026-07-31 Fri 14:00>\n" + (let ((row (car rows))) + (should (eq :null (alist-get 'end row))) + (should (= (alist-get 'e row) (alist-get 's row)))))) + +(ert-deftest test-agenda-render-boundary-every-row-is-drawable () + "Boundary: across a mixed day, every row has integer s and e with e >= s. +This is the invariant the surface depends on, so it is asserted over the whole +set rather than one row at a time." + (test-aq-render--with-agenda-file + (concat "* TODO All day\nSCHEDULED: <2026-07-31 Fri>\n" + "* Point\n<2026-07-31 Fri 14:00>\n" + "* Ranged\n<2026-07-31 Fri 15:00-16:30>\n" + "* TODO Deadline day\nDEADLINE: <2026-07-31 Fri 17:00>\n") + (should (= 4 (length rows))) + (dolist (row rows) + (should (integerp (alist-get 's row))) + (should (integerp (alist-get 'e row))) + (should (>= (alist-get 'e row) (alist-get 's row))) + (should (stringp (alist-get 't row)))))) + +(ert-deftest test-agenda-render-boundary-empty-is-array () + "Boundary: an empty day is an empty array, not null. +The renderer parses the same shape whether or not anything is scheduled." + (let ((org-agenda-files nil)) + (should (equal "[]" (cj/agenda-render-json 1785474000 1785477600))))) + +;;; ---------- the batch reader has to know the keyword vocabulary ---------- + +(ert-deftest test-agenda-render-normal-custom-keyword-is-parsed () + "Normal: a config keyword is recognised, so it leaves the title. + +The batch writer runs without the editor's init, so it has to set +`org-todo-keywords' itself. When it does not, org stops parsing the headline +as a task at all: DOING and the priority cookie stay glued to the front of the +title and the row reads as having no keyword. That is a wrong answer that +still parses as JSON, which is the worst kind." + (let ((org-todo-keywords cj/org-todo-keywords)) + (test-aq-render--with-agenda-file + "* DOING [#A] Justin Johns advisor projects\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (let ((row (car rows))) + (should (equal "Justin Johns advisor projects" (alist-get 't row))) + (should (equal "DOING" (alist-get 'keyword row))))))) + +(ert-deftest test-agenda-render-boundary-unknown-keyword-stays-in-title () + "Boundary: with stock keywords the same headline degrades visibly. + +Pinning the failure mode, not endorsing it. This is what the surface showed +before the batch writer learned the vocabulary, and it is why the test above +exists." + (let ((org-todo-keywords '((sequence "TODO" "|" "DONE")))) + (test-aq-render--with-agenda-file + "* DOING [#A] Justin Johns advisor projects\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (string-prefix-p "DOING" (alist-get 't (car rows))))))) + +;;; ---------- the cache writer ---------- + +(ert-deftest test-agenda-render-normal-cache-update-writes-today () + "Normal: the cache writer covers three whole local days and creates its dir. + +Yesterday's midnight through tomorrow's day close. A consumer drawing a +rolling window centred on now needs both sides of midnight: with a single +calendar day, the part of its span outside today has nothing to draw, which +late in the evening is half the surface. + +This is the function that actually ships the feature, so it gets its own +coverage rather than riding on the tests for the profile beneath it. The +window assertion is the point: a writer that quietly covered the last hour, +or the next 24 from now, would still produce a plausible-looking file." + (let* ((dir (make-temp-file "agenda-cache-" t)) + ;; A path two levels deep, so directory creation is exercised. + (cj/agenda-render-cache-file + (expand-file-name "settings/agenda.json" dir)) + (org-agenda-files nil) + (windows '())) + (unwind-protect + (cl-letf (((symbol-function 'cj/agenda-render-json) + (lambda (start end &optional out) + (push (cons start end) windows) + (when out (cj/--agenda-query-write-atomically out "[]")) + "[]"))) + (should (equal cj/agenda-render-cache-file + (cj/agenda-render-cache-update))) + (should (file-exists-p cj/agenda-render-cache-file)) + (let* ((window (car windows)) + (start (decode-time (car window))) + (now (decode-time))) + ;; Opens at local midnight... + (should (= 0 (nth 2 start))) + (should (= 0 (nth 1 start))) + (should (= 0 (nth 0 start))) + ;; ...on yesterday, and closes at the end of tomorrow. + (should (= (car window) + (cj/--agenda-query-epoch + 0 0 0 (1- (nth 3 now)) (nth 4 now) (nth 5 now)))) + (should (= (cdr window) + (cj/--agenda-query-day-close + (1+ (nth 3 now)) (nth 4 now) (nth 5 now)))) + ;; Three whole days, give or take an hour at a DST changeover. + (let ((hours (/ (- (cdr window) (car window)) 3600.0))) + (should (>= hours 70.9)) + (should (<= hours 73.1))))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-render-boundary-cache-update-is-idempotent () + "Boundary: writing twice leaves one file and no temp litter." + (let* ((dir (make-temp-file "agenda-cache-" t)) + (cj/agenda-render-cache-file (expand-file-name "agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (cj/agenda-render-cache-update) + (cj/agenda-render-cache-update) + (should (equal '("agenda.json") + (directory-files + dir nil directory-files-no-dot-files-regexp)))) + (delete-directory dir t)))) + +;;; Error Cases + +(ert-deftest test-agenda-render-error-cache-update-unwritable-parent () + "Error: an unwritable cache location signals rather than failing silently. +A silent failure here looks identical to an empty agenda on the surface." + (let* ((dir (make-temp-file "agenda-cache-ro-" t)) + (cj/agenda-render-cache-file + (expand-file-name "settings/agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (set-file-modes dir #o500) + (should-error (cj/agenda-render-cache-update))) + (set-file-modes dir #o700) + (delete-directory dir t)))) + +(ert-deftest test-agenda-render-error-bounds-are-still-seconds () + "Error: the render profile takes SECONDS in, even though it emits +milliseconds. The direction of conversion is one-way and the input guards +still apply, so a caller passing milliseconds is told rather than answered." + (let ((org-agenda-files nil) + (ms 1785474000000)) + (should-error (cj/agenda-render-json ms (+ ms 3600000)) :type 'user-error))) + +;;; Back to Normal Cases -- the profile's own writer + +(ert-deftest test-agenda-render-normal-writes-out-path () + "Normal: with an out-path the render profile writes it atomically." + (let* ((dir (make-temp-file "agenda-render-out-" t)) + (out (expand-file-name "agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (cj/agenda-render-json 1785474000 1785477600 out) + (should (file-exists-p out)) + (with-temp-buffer + (insert-file-contents out) + (should (equal "[]" (buffer-string)))) + (should (zerop (logand (file-modes out) #o111)))) + (delete-directory dir t)))) + +(provide 'test-agenda-query--render) +;;; test-agenda-query--render.el ends here diff --git a/tests/test-agenda-query.el b/tests/test-agenda-query.el new file mode 100644 index 00000000..4b6b0dc1 --- /dev/null +++ b/tests/test-agenda-query.el @@ -0,0 +1,381 @@ +;;; test-agenda-query.el --- Tests for the agenda JSON query -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/--agenda-query-buffer-events', `cj/agenda-window-json' and the +;; atomic writer. +;; +;; The load-bearing test here is the SCHEDULED/DEADLINE one. Org stores +;; planning timestamps as properties on a `planning' element rather than as +;; children in the parse tree, so the obvious implementation -- mapping over +;; \='timestamp -- returns neither, silently. A fixture without a SCHEDULED +;; entry would pass against that broken implementation, so every fixture that +;; matters carries one. +;; +;; Helpers carry a file-unique prefix on purpose: the editor hook loads every +;; agenda-query test file into ONE process, so a shared helper name here would +;; silently redefine its namesake in a sibling file. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) +(require 'seq) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) + +(defun test-aq-json--epoch (min hour day month year) + "Return the epoch for local MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list 0 min hour day month year nil -1 nil)) + 'integer)) + +(defun test-aq-json--day-window () + "Return the window covering all of 2026-07-31 as a cons." + (cons (test-aq-json--epoch 0 0 31 7 2026) + (test-aq-json--epoch 59 23 31 7 2026))) + +(defmacro test-aq-json--with-org (text &rest body) + "Parse TEXT in an org-mode buffer and run BODY with `events' bound. +`events' holds the rows the buffer contributes for all of 2026-07-31." + (declare (indent 1)) + `(with-temp-buffer + (insert ,text) + (org-mode) + (let* ((window (test-aq-json--day-window)) + (events (cj/--agenda-query-buffer-events + (current-buffer) "/tmp/fixture.org" + (car window) (cdr window)))) + ,@body))) + +(defun test-aq-json--field (event key) + "Return EVENT's KEY, a symbol." + (alist-get key event)) + +(defun test-aq-json--of-type (events type) + "Return the EVENTS whose type is TYPE." + (seq-filter (lambda (e) (equal type (test-aq-json--field e 'type))) events)) + +(defmacro test-aq-json--with-agenda-file (text &rest body) + "Write TEXT to a temp agenda file and run BODY with `file' and `window' bound. +Kills the visited buffer afterwards so the run leaves no state behind." + (declare (indent 1)) + `(let* ((dir (make-temp-file "agenda-query-" t)) + (file (expand-file-name "todo.org" dir)) + (window (test-aq-json--day-window))) + (unwind-protect + (progn + (with-temp-file file (insert ,text)) + (let ((org-agenda-files (list file))) + ,@body)) + (dolist (buffer (buffer-list)) + (when (equal (buffer-file-name buffer) file) (kill-buffer buffer))) + (delete-directory dir t)))) + +;;; ---------- the planning-property trap ---------- + +(ert-deftest test-agenda-query-normal-scheduled-and-deadline-are-found () + "Normal: SCHEDULED and DEADLINE both reach the output. + +These are properties on the planning element, not children in the parse tree. +An implementation that maps over \='timestamp returns the body stamp only and +drops these two silently -- so this asserts they are present, not merely that +the count is right." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00> DEADLINE: <2026-07-31 Fri 17:00>\nBody <2026-07-31 Fri 14:00>\n" + (should (= 1 (length (test-aq-json--of-type events "scheduled")))) + (should (= 1 (length (test-aq-json--of-type events "deadline")))) + (should (= 1 (length (test-aq-json--of-type events "timestamp")))) + (should (equal (test-aq-json--epoch 0 9 31 7 2026) + (test-aq-json--field + (car (test-aq-json--of-type events "scheduled")) 'start))) + (should (equal (test-aq-json--epoch 0 17 31 7 2026) + (test-aq-json--field + (car (test-aq-json--of-type events "deadline")) 'start))))) + +(ert-deftest test-agenda-query-normal-scheduled-alone-is-found () + "Normal: an entry whose only timestamp is SCHEDULED still produces a row. +The positive control for the trap: with no body timestamp to mask it, a broken +implementation returns nothing at all here." + (test-aq-json--with-org + "* TODO Water plants\nSCHEDULED: <2026-07-31 Fri>\n" + (should (= 1 (length events))) + (should (equal "scheduled" (test-aq-json--field (car events) 'type))))) + +;;; ---------- field content ---------- + +(ert-deftest test-agenda-query-normal-title-is-stripped () + "Normal: the title carries no keyword, priority cookie or tags." + (test-aq-json--with-org + "* TODO [#A] Standup with Nerses :work:urgent:\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "Standup with Nerses" + (test-aq-json--field (car events) 'title))))) + +(ert-deftest test-agenda-query-normal-title-renders-org-links () + "Normal: an org link in the title becomes its description text. + +Craig's captured web items carry link syntax in the headline, so this is not +hypothetical -- his live agenda has one today. A wallpaper showing +\"[[https://…][Tracking your habits]]\" is a bug the consumer cannot fix +without parsing org markup." + (test-aq-json--with-org + "* TODO [[https://orgmode.org/x][Tracking your habits]]\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "Tracking your habits" + (test-aq-json--field (car events) 'title)))) + ;; A bare link has no description, so its target is the best available text. + (test-aq-json--with-org + "* TODO [[https://orgmode.org/x]]\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "https://orgmode.org/x" + (test-aq-json--field (car events) 'title))))) + +(ert-deftest test-agenda-query-normal-location-and-organizer () + "Normal: LOCATION and ORGANIZER properties reach the row." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n:PROPERTIES:\n:LOCATION: Room 3\n:ORGANIZER: Nerses\n:END:\n" + (should (equal "Room 3" (test-aq-json--field (car events) 'location))) + (should (equal "Nerses" (test-aq-json--field (car events) 'organizer))))) + +(ert-deftest test-agenda-query-normal-completion-state () + "Normal: a closed entry reports done true and keeps its raw keyword. +Without this a DONE task carrying today's SCHEDULED renders as an upcoming +event, and the error compounds over a working day." + (test-aq-json--with-org + "* DONE Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (eq t (test-aq-json--field (car events) 'done))) + (should (equal "DONE" (test-aq-json--field (car events) 'keyword))))) + +(ert-deftest test-agenda-query-boundary-open-task-is-not-done () + "Boundary: an open task reports done false, not null or missing." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (eq :false (test-aq-json--field (car events) 'done))) + (should (equal "TODO" (test-aq-json--field (car events) 'keyword))))) + +(ert-deftest test-agenda-query-boundary-plain-headline-has-null-keyword () + "Boundary: an entry with no keyword reports null rather than an empty string." + (test-aq-json--with-org + "* Lunch\n<2026-07-31 Fri 12:00-13:00>\n" + (should (eq :null (test-aq-json--field (car events) 'keyword))) + (should (eq :false (test-aq-json--field (car events) 'done))))) + +(ert-deftest test-agenda-query-boundary-repeater-cookie-in-row () + "Boundary: a repeating entry carries its raw cookie so the consumer can mark it." + (test-aq-json--with-org + "* TODO Water plants\nSCHEDULED: <2026-07-01 Wed 09:00 +1d>\n" + (should (= 1 (length events))) + (should (equal "+1d" (test-aq-json--field (car events) 'repeater))) + (should (equal (test-aq-json--epoch 0 9 31 7 2026) + (test-aq-json--field (car events) 'start))))) + +(ert-deftest test-agenda-query-boundary-absent-fields-are-null () + "Boundary: absent optional values are null, so the shape stays stable." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri>\n" + (let ((event (car events))) + (should (eq :null (test-aq-json--field event 'end))) + (should (eq :null (test-aq-json--field event 'location))) + (should (eq :null (test-aq-json--field event 'organizer))) + (should (eq :null (test-aq-json--field event 'repeater))) + (should (eq t (test-aq-json--field event 'all-day)))))) + +;;; ---------- selection ---------- + +(ert-deftest test-agenda-query-boundary-inactive-excluded () + "Boundary: an inactive timestamp never reaches an agenda, so it is excluded." + (test-aq-json--with-org + "* Note\nLogged [2026-07-31 Fri 10:00]\n" + (should-not events))) + +(ert-deftest test-agenda-query-boundary-nested-headlines-not-double-counted () + "Boundary: a child's timestamp belongs to the child alone. +Collecting per-headline by mapping a headline's whole subtree would attribute +each child stamp to every ancestor too." + (test-aq-json--with-org + "* Parent\nSCHEDULED: <2026-07-31 Fri 09:00>\n** Child\nSCHEDULED: <2026-07-31 Fri 11:00>\n" + (should (= 2 (length events))) + (should (equal '("Parent" "Child") + (mapcar (lambda (e) (test-aq-json--field e 'title)) events))))) + +(ert-deftest test-agenda-query-boundary-archived-and-commented-excluded () + "Boundary: archived and commented subtrees are skipped, as org's agenda does. +A query that disagrees with the agenda Craig sees is worse than one returning +less, and both of these are off his agenda." + (test-aq-json--with-org + (concat "* Archived thing :ARCHIVE:\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + "* COMMENT Commented\nSCHEDULED: <2026-07-31 Fri 10:00>\n" + "* Live\nSCHEDULED: <2026-07-31 Fri 11:00>\n") + (should (equal '("Live") + (mapcar (lambda (e) (test-aq-json--field e 'title)) events))))) + +(ert-deftest test-agenda-query-boundary-archive-applies-to-children () + "Boundary: archiving a parent takes its whole subtree off the agenda." + (test-aq-json--with-org + (concat "* Parent :ARCHIVE:\n** Child\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + "* Live\nSCHEDULED: <2026-07-31 Fri 11:00>\n") + (should (equal '("Live") + (mapcar (lambda (e) (test-aq-json--field e 'title)) events))))) + +(ert-deftest test-agenda-query-boundary-outside-window-excluded () + "Boundary: an entry on another day contributes nothing." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-08-15 Sat 09:00>\n" + (should-not events))) + +(ert-deftest test-agenda-query-boundary-empty-buffer () + "Boundary: an empty buffer yields no rows." + (test-aq-json--with-org "" (should-not events))) + +;;; ---------- error cases ---------- + +(ert-deftest test-agenda-query-error-diary-sexp-is-skipped () + "Error: a diary sexp timestamp cannot expand to an instant, and is skipped +without signaling -- one unusable entry must not fail the whole query." + (test-aq-json--with-org + "* Floating\n<%%(diary-float t 3 3)>\n* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (= 1 (length events))) + (should (equal "Standup" (test-aq-json--field (car events) 'title))))) + +(ert-deftest test-agenda-query-error-headline-without-timestamp () + "Error: an entry with no timestamp at all contributes nothing." + (test-aq-json--with-org "* TODO Someday\nJust prose.\n" + (should-not events))) + +;;; ---------- JSON output ---------- + +(ert-deftest test-agenda-query-normal-json-round-trips () + "Normal: the output parses as JSON and preserves the fields. +Booleans arrive as real JSON booleans and absent values as null, so the +consumer can test on them rather than string-matching." + (test-aq-json--with-agenda-file + "* DONE Standup\nSCHEDULED: <2026-07-31 Fri 09:00-09:30>\n" + (let* ((json (cj/agenda-window-json (car window) (cdr window))) + (parsed (json-parse-string json :object-type 'alist))) + (should (= 1 (length parsed))) + (let ((event (aref parsed 0))) + (should (equal "Standup" (alist-get 'title event))) + (should (eq t (alist-get 'done event))) + (should (eq :false (alist-get 'all-day event))) + (should (equal file (alist-get 'file event))) + (should (eq :null (alist-get 'repeater event))) + (should (equal (test-aq-json--epoch 30 9 31 7 2026) + (alist-get 'end event))))))) + +(ert-deftest test-agenda-query-boundary-json-empty-is-array () + "Boundary: an empty result is an empty JSON array, never null. +The consumer parses the same shape whether or not anything is scheduled." + (let ((org-agenda-files nil)) + (should (equal "[]" (cj/agenda-window-json 0 100))))) + +(ert-deftest test-agenda-query-boundary-json-sorted-by-start () + "Boundary: rows come back in start order regardless of file order." + (test-aq-json--with-agenda-file + "* Late\nSCHEDULED: <2026-07-31 Fri 17:00>\n* Early\nSCHEDULED: <2026-07-31 Fri 08:00>\n" + (let ((parsed (json-parse-string + (cj/agenda-window-json (car window) (cdr window)) + :object-type 'alist))) + (should (equal '("Early" "Late") + (mapcar (lambda (e) (alist-get 'title e)) + (append parsed nil))))))) + +(ert-deftest test-agenda-query-error-json-rejects-non-numeric-bounds () + "Error: a non-numeric bound signals rather than returning a wrong answer." + (should-error (cj/agenda-window-json "now" 100) :type 'wrong-type-argument) + (should-error (cj/agenda-window-json 0 nil) :type 'wrong-type-argument)) + +(ert-deftest test-agenda-query-error-rejects-absurdly-wide-window () + "Error: a window wider than the cap signals instead of trying to answer. + +This is the milliseconds-for-seconds mistake, which a JavaScript consumer +makes by passing `Date.now()' straight through. Answering it means building +tens of millions of rows inside the daemon Craig is working in; a renderer +losing one frame is much the cheaper failure." + (let ((org-agenda-files nil) + (now 1785474000)) + (should-error (cj/agenda-window-json now (* now 1000)) :type 'user-error) + ;; A window at the cap is still answered. + (should (equal "[]" (cj/agenda-window-json + now (+ now cj/agenda-query-max-window-seconds)))))) + +(ert-deftest test-agenda-query-error-rejects-millisecond-bounds () + "Error: BOTH bounds in milliseconds is rejected on magnitude. + +This is the likelier shape of the units mistake and the width cap cannot see +it: `Date.now()' and `Date.now() + 3600000' look like a 41-day window, so it +passes the width check and answers with timestamps in the year 58549. A +wrong answer that parses is worse than an error." + (let ((org-agenda-files nil) + (ms 1785474000000)) + (should-error (cj/agenda-window-json ms (+ ms 3600000)) :type 'user-error) + ;; The same instants in seconds are a perfectly ordinary request. + (should (equal "[]" (cj/agenda-window-json 1785474000 1785477600))))) + +;;; ---------- atomic write ---------- + +(ert-deftest test-agenda-query-normal-writes-file-atomically () + "Normal: OUT-PATH receives the JSON and no temp file is left behind." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (out (expand-file-name "agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (should (equal "[]" (cj/agenda-window-json 0 100 out))) + (should (file-exists-p out)) + (with-temp-buffer + (insert-file-contents out) + (should (equal "[]" (buffer-string)))) + ;; The rename consumed the temp file; only the target remains. + (should (equal '("agenda.json") + (directory-files + dir nil directory-files-no-dot-files-regexp)))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-query-boundary-write-is-readable-by-others () + "Boundary: the written file is not left at the temp file's private 0600. + +`make-temp-file' creates 0600, and the rename carries that mode onto the +target. The whole point of OUT-PATH is that another process reads it, so a +private mode would work only while the reader runs as Craig." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (out (expand-file-name "agenda.json" dir))) + (unwind-protect + (progn + (cj/--agenda-query-write-atomically out "[]") + ;; Readable beyond the owner, following the session umask... + (should (= (logand (file-modes out) #o044) + (logand #o044 (default-file-modes)))) + ;; ...but never executable. `default-file-modes' is 777 minus the + ;; umask, so using it unmasked publishes the JSON as 0755. + ;; No assertion that the mode differs from 0600: under umask 077 + ;; that IS the correct answer, and asserting otherwise would fail + ;; for a reason that has nothing to do with this code. + (should (zerop (logand (file-modes out) #o111)))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-query-boundary-write-replaces-existing () + "Boundary: an existing file is replaced wholesale, not appended to." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (out (expand-file-name "agenda.json" dir))) + (unwind-protect + (progn + (with-temp-file out (insert "stale content that is much longer")) + (cj/--agenda-query-write-atomically out "[]") + (with-temp-buffer + (insert-file-contents out) + (should (equal "[]" (buffer-string))))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-query-error-write-to-missing-dir-preserves-target () + "Error: a write into a nonexistent directory signals and litters nothing." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (missing (expand-file-name "nope/agenda.json" dir))) + (unwind-protect + (progn + (should-error (cj/--agenda-query-write-atomically missing "[]")) + (should-not (file-exists-p missing)) + (should-not (directory-files + dir nil directory-files-no-dot-files-regexp))) + (delete-directory dir t)))) + +(provide 'test-agenda-query) +;;; test-agenda-query.el ends here diff --git a/tests/test-agenda-render-cache.bats b/tests/test-agenda-render-cache.bats new file mode 100644 index 00000000..3e949c16 --- /dev/null +++ b/tests/test-agenda-render-cache.bats @@ -0,0 +1,131 @@ +#!/usr/bin/env bats +# Tests for scripts/agenda-render-cache — the batch writer behind the timer. +# +# The elisp tests cover the query and the row shape. What only a shell test +# can cover is the thing that actually broke: the script runs a batch Emacs +# with -Q, so none of the editor's configuration is loaded, and anything it +# forgets to set up degrades silently rather than erroring. The first version +# wrote a file that parsed fine and was wrong, because org did not know DOING +# was a keyword and left it glued to the front of every title. +# +# Two isolation rules, both learned the hard way: +# +# EMACS_D points at THIS checkout, not $HOME/.emacs.d. Without it the script +# under test runs the installed config's elisp, so a broken tree passes. +# +# AGENDA_RENDER_FILES points at a fixture written here. Asserting over the +# machine's real agenda makes the result depend on what Craig happens to have +# scheduled today: the keyword assertion only bites if some entry carries a +# keyword, and on an empty agenda every all() assertion passes over an empty +# list. The fixture makes the failure mode reachable every run. + +setup() { + SCRIPT="${BATS_TEST_DIRNAME}/../scripts/agenda-render-cache" + export EMACS_D="${BATS_TEST_DIRNAME}/.." + export XDG_CACHE_HOME="${BATS_TEST_TMPDIR}/cache" + OUT="${XDG_CACHE_HOME}/settings/agenda.json" + + FIXTURE="${BATS_TEST_TMPDIR}/fixture.org" + TODAY="$(date +%Y-%m-%d)" + DOW="$(date +%a)" + { + printf '* DOING [#A] Advisor projects\nSCHEDULED: <%s %s 09:00>\n' "$TODAY" "$DOW" + printf '* TODO Standup\nSCHEDULED: <%s %s 10:00-10:15>\n' "$TODAY" "$DOW" + printf '* Lunch\n<%s %s 12:00-13:00>\n' "$TODAY" "$DOW" + printf '* VERIFY [#B] Check the render\nDEADLINE: <%s %s 17:00>\n' "$TODAY" "$DOW" + } > "$FIXTURE" + export AGENDA_RENDER_FILES="$FIXTURE" +} + +# Every assertion below runs through this, so an empty result can never pass +# vacuously — all() over an empty list is true, which is how a writer that +# produced nothing would look like a writer that produced correct rows. +assert_json() { + python3 -c " +import json, sys +rows = json.load(open(sys.argv[1])) +assert isinstance(rows, list), 'not a JSON array' +assert len(rows) == 4, 'expected 4 fixture rows, got %d' % len(rows) +$1 +" "$OUT" +} + +@test "the script is executable" { + [ -x "$SCRIPT" ] +} + +@test "writes a parseable JSON array and creates its directory" { + run "$SCRIPT" + [ "$status" -eq 0 ] + [ -f "$OUT" ] + run assert_json "pass" + [ "$status" -eq 0 ] +} + +@test "every row carries the three keys the renderer reads" { + run "$SCRIPT" + [ "$status" -eq 0 ] + run assert_json " +assert all({'s','e','t'} <= set(r) for r in rows), 'missing s/e/t' +assert all(isinstance(r['s'], int) and isinstance(r['e'], int) for r in rows), 'non-integer instant' +assert all(r['e'] >= r['s'] for r in rows), 'negative duration' +" + [ "$status" -eq 0 ] +} + +@test "instants are milliseconds, not seconds" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # Seconds since 1970 are 10 digits; milliseconds are 13. + run assert_json "assert all(len(str(r['s'])) == 13 for r in rows), 'looks like seconds'" + [ "$status" -eq 0 ] +} + +@test "titles do not carry the TODO keyword vocabulary" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # The regression this file exists for. The fixture carries DOING, TODO and + # VERIFY entries plus two priority cookies, so a script that has not set + # org-todo-keywords fails here every run rather than only on days when + # Craig happens to have such an entry. + run assert_json " +KEYWORDS = {'TODO','PROJECT','DOING','WAITING','VERIFY','STALLED', + 'DELEGATED','FAILED','DONE','CANCELLED'} +bad = [r['t'] for r in rows if r['t'].split(' ')[0] in KEYWORDS] +assert not bad, 'keyword left in title: %r' % bad +cookie = [r['t'] for r in rows if r['t'].startswith('[#')] +assert not cookie, 'priority cookie left in title: %r' % cookie +assert sorted(r['t'] for r in rows) == [ + 'Advisor projects', 'Check the render', 'Lunch', 'Standup'] +" + [ "$status" -eq 0 ] +} + +@test "keyword and completion state survive the batch environment" { + run "$SCRIPT" + [ "$status" -eq 0 ] + run assert_json " +by_title = {r['t']: r for r in rows} +assert by_title['Advisor projects']['keyword'] == 'DOING', by_title['Advisor projects'] +assert by_title['Check the render']['keyword'] == 'VERIFY' +assert by_title['Lunch']['keyword'] is None +assert all(r['done'] is False for r in rows) +assert by_title['Check the render']['type'] == 'deadline' +" + [ "$status" -eq 0 ] +} + +@test "replaces an existing file rather than appending" { + mkdir -p "$(dirname "$OUT")" + printf 'stale garbage that is not json at all\n' > "$OUT" + run "$SCRIPT" + [ "$status" -eq 0 ] + run assert_json "pass" + [ "$status" -eq 0 ] +} + +@test "fails loudly when the config directory is missing" { + run env EMACS_D="${BATS_TEST_TMPDIR}/nonexistent" "$SCRIPT" + [ "$status" -ne 0 ] + [[ "$output" == *"no modules directory"* ]] +} diff --git a/tests/test-ai-term--attached-agent-dirs.el b/tests/test-ai-term--attached-agent-dirs.el new file mode 100644 index 00000000..bdd69544 --- /dev/null +++ b/tests/test-ai-term--attached-agent-dirs.el @@ -0,0 +1,58 @@ +;;; test-ai-term--attached-agent-dirs.el --- Tests for cj/--ai-term-attached-agent-dirs -*- lexical-binding: t; -*- + +;;; Commentary: +;; The queue `cj/ai-term-next-attached' (M-SPC) steps through: project dirs +;; with a live agent BUFFER only -- attached sessions. Unlike +;; `cj/--ai-term-active-agent-dirs', detached tmux sessions with no Emacs +;; buffer are excluded; those are reachable only via `cj/ai-term-next' +;; (M-S-SPC). Candidates / buffers / sessions are mocked so the enumeration +;; logic is exercised without a real tmux server. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(ert-deftest test-ai-term--attached-agent-dirs-excludes-detached () + "Normal: only dirs with a live buffer are attached; a detached session is +excluded even though it is active." + (let ((buf (get-buffer-create (cj/--ai-term-buffer-name "/p/alpha")))) + (unwind-protect + (cl-letf (((symbol-function 'cj/--ai-term-candidates) + (lambda (&rest _) '("/p/alpha" "/p/beta" "/p/gamma" "/p/delta"))) + ((symbol-function 'cj/--ai-term-agent-buffers) + (lambda (&rest _) (list buf))) + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda (&rest _) (list (cj/--ai-term-tmux-session-name "/p/gamma"))))) + ;; alpha attached (buffer), gamma detached (session): only alpha. + (should (equal '("/p/alpha") (cj/--ai-term-attached-agent-dirs)))) + (kill-buffer buf)))) + +(ert-deftest test-ai-term--attached-agent-dirs-multiple-sorted () + "Normal: multiple attached dirs come back sorted by agent buffer name." + (let ((a (get-buffer-create (cj/--ai-term-buffer-name "/p/delta"))) + (b (get-buffer-create (cj/--ai-term-buffer-name "/p/alpha")))) + (unwind-protect + (cl-letf (((symbol-function 'cj/--ai-term-candidates) + (lambda (&rest _) '("/p/alpha" "/p/beta" "/p/delta"))) + ((symbol-function 'cj/--ai-term-agent-buffers) + (lambda (&rest _) (list a b))) + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda (&rest _) nil))) + (should (equal '("/p/alpha" "/p/delta") (cj/--ai-term-attached-agent-dirs)))) + (kill-buffer a) + (kill-buffer b)))) + +(ert-deftest test-ai-term--attached-agent-dirs-empty-when-only-detached () + "Boundary: sessions exist but no live buffers -> no attached dirs." + (cl-letf (((symbol-function 'cj/--ai-term-candidates) (lambda (&rest _) '("/p/solo"))) + ((symbol-function 'cj/--ai-term-agent-buffers) (lambda (&rest _) nil)) + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda (&rest _) (list (cj/--ai-term-tmux-session-name "/p/solo"))))) + (should (null (cj/--ai-term-attached-agent-dirs))))) + +(provide 'test-ai-term--attached-agent-dirs) +;;; test-ai-term--attached-agent-dirs.el ends here diff --git a/tests/test-ai-term--buffer-name.el b/tests/test-ai-term--buffer-name.el index b241977d..e728bc82 100644 --- a/tests/test-ai-term--buffer-name.el +++ b/tests/test-ai-term--buffer-name.el @@ -38,5 +38,26 @@ (should (equal (cj/--ai-term-buffer-name "/a/b/c/d/e/leaf") "agent [leaf]"))) +;;; Basename extraction (inverse transform) + +(ert-deftest test-ai-term--buffer-basename-normal-round-trip () + "Normal: extracts the basename embedded in an agent buffer's name." + (let ((buf (get-buffer-create "agent [proj]"))) + (unwind-protect + (should (equal (cj/--ai-term-buffer-basename buf) "proj")) + (kill-buffer buf)))) + +(ert-deftest test-ai-term--buffer-basename-boundary-dotted () + "Boundary: dotted basenames (.emacs.d) survive extraction intact." + (let ((buf (get-buffer-create "agent [.emacs.d]"))) + (unwind-protect + (should (equal (cj/--ai-term-buffer-basename buf) ".emacs.d")) + (kill-buffer buf)))) + +(ert-deftest test-ai-term--buffer-basename-error-non-agent-nil () + "Error: a non-agent buffer yields nil." + (with-temp-buffer + (should (null (cj/--ai-term-buffer-basename (current-buffer)))))) + (provide 'test-ai-term--buffer-name) ;;; test-ai-term--buffer-name.el ends here diff --git a/tests/test-ai-term--close.el b/tests/test-ai-term--close.el index 242bfd74..8b028351 100644 --- a/tests/test-ai-term--close.el +++ b/tests/test-ai-term--close.el @@ -36,8 +36,22 @@ (lambda (&rest _) (error "no tmux")))) (should (null (cj/--ai-term-kill-tmux-session "aiv-foo"))))) +(ert-deftest test-ai-term--close-buffer-session-from-name-after-cd () + "Regression: the session name comes from the immutable buffer name. +ghostel retargets `default-directory' via OSC 7 as the shell cds, so +deriving from it after a cd kills the wrong aiv- session (or misses, +orphaning the agent). The buffer name's basename never changes." + (let ((buf (get-buffer-create "agent [proj]")) + captured-session) + (with-current-buffer buf (setq-local default-directory "/tmp/elsewhere/")) + (cl-letf (((symbol-function 'cj/--ai-term-kill-tmux-session) + (lambda (s) (setq captured-session s) 0))) + (cj/--ai-term-close-buffer buf)) + (should (equal captured-session "aiv-proj")) + (should-not (buffer-live-p buf)))) + (ert-deftest test-ai-term--close-buffer-kills-session-and-buffer () - "Normal: derives the session from default-directory, kills it and the buffer." + "Normal: derives the session from the buffer name, kills it and the buffer." (let ((buf (get-buffer-create "agent [foo]")) captured-session) (with-current-buffer buf (setq-local default-directory "/tmp/foo/")) diff --git a/tests/test-ai-term--keybindings.el b/tests/test-ai-term--keybindings.el index 6f7f53a5..8b1f8fa5 100644 --- a/tests/test-ai-term--keybindings.el +++ b/tests/test-ai-term--keybindings.el @@ -33,14 +33,18 @@ (should (eq (keymap-lookup cj/custom-keymap "a") cj/ai-term-keymap))) (ert-deftest test-ai-term-next-bound-to-meta-space-globally () - "Normal: M-SPC runs `cj/ai-term-next' (the fast swap chord)." - (should (eq (lookup-key (current-global-map) (kbd "M-SPC")) #'cj/ai-term-next))) + "Normal: M-SPC runs `cj/ai-term-next-attached' (cycle attached only) and +M-S-SPC runs `cj/ai-term-next' (cycle all, including detached)." + (should (eq (lookup-key (current-global-map) (kbd "M-SPC")) #'cj/ai-term-next-attached)) + (should (eq (lookup-key (current-global-map) (kbd "M-S-SPC")) #'cj/ai-term-next))) (ert-deftest test-ai-term-meta-space-bound-in-eat-semi-char-mode-map () - "Normal: M-SPC is bound in `eat-semi-char-mode-map' so swap works inside an -agent. EAT forwards unbound keys to the pty, so the bind is what lets it reach -Emacs -- no ghostel-style exception list or rebuild is needed." - (should (eq (keymap-lookup eat-semi-char-mode-map "M-SPC") #'cj/ai-term-next))) + "Normal: both swap chords are bound in `eat-semi-char-mode-map' so they work +inside an agent. EAT forwards unbound keys to the pty, so the bind is what lets +them reach Emacs -- no ghostel-style exception list or rebuild is needed. M-SPC +cycles attached only; M-S-SPC cycles all." + (should (eq (keymap-lookup eat-semi-char-mode-map "M-SPC") #'cj/ai-term-next-attached)) + (should (eq (keymap-lookup eat-semi-char-mode-map "M-S-SPC") #'cj/ai-term-next))) (ert-deftest test-ai-term-f9-family-removed-globally () "Regression: the old F9 family no longer binds the ai-term commands globally." diff --git a/tests/test-ai-term--quit.el b/tests/test-ai-term--quit.el index 55ace81d..64b8a5d4 100644 --- a/tests/test-ai-term--quit.el +++ b/tests/test-ai-term--quit.el @@ -43,6 +43,22 @@ (should-not (buffer-live-p buf))) (when (buffer-live-p buf) (kill-buffer buf))))) +(ert-deftest test-ai-term-quit-nil-project-from-drifted-agent-buffer () + "Regression: nil PROJECT inside an agent buffer keys off the buffer name. +After a cd in the agent shell, ghostel's OSC 7 tracking moves the buffer's +`default-directory' away from the project, so keying off it would kill the +wrong session and miss the buffer." + (let ((buf (get-buffer-create "agent [realproj]")) + (calls nil)) + (unwind-protect + (test-ai-term-quit--with-tmux calls + (with-current-buffer buf + (setq-local default-directory "/tmp/elsewhere/") + (cj/ai-term-quit)) + (should (member '("kill-session" "-t" "aiv-realproj") calls)) + (should-not (buffer-live-p buf))) + (when (buffer-live-p buf) (kill-buffer buf))))) + (ert-deftest test-ai-term-quit-idempotent-when-gone () "Error/Boundary: a second quit (session + buffer already gone) does not error." (let ((calls nil)) diff --git a/tests/test-ai-term--session-threading.el b/tests/test-ai-term--session-threading.el new file mode 100644 index 00000000..984f76d7 --- /dev/null +++ b/tests/test-ai-term--session-threading.el @@ -0,0 +1,40 @@ +;;; test-ai-term--session-threading.el --- Session-list threading tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The launch path used to call cj/--ai-term-live-tmux-sessions (a tmux +;; subprocess) once in the project picker, again for the launcher's fresh +;; check, and a third time inside show-or-create. One fetch per launch, +;; threaded through, is the contract pinned here. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +(ert-deftest test-ai-term-launch-fetches-tmux-sessions-once () + "Normal: one tmux session fetch per launch, threaded to the picker and +show-or-create rather than re-spawned by each." + (let ((fetches 0) received-sessions) + (cl-letf (((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda () (setq fetches (1+ fetches)) '("other"))) + ((symbol-function 'cj/--ai-term-candidates) + (lambda () '("/tmp/proj/"))) + ((symbol-function 'completing-read) + (lambda (_prompt table &rest _) + (car (all-completions "" table)))) + ((symbol-function 'get-buffer) (lambda (_n) nil)) + ((symbol-function 'cj/--ai-term-pick-runtime) (lambda () 'claude)) + ((symbol-function 'cj/--ai-term-runtime-command) (lambda (_r) "cmd")) + ((symbol-function 'cj/--ai-term-show-or-create) + (lambda (_dir _name _cmd &optional sessions) + (setq received-sessions sessions) + (current-buffer))) + ((symbol-function 'get-buffer-window) (lambda (&rest _) nil))) + (cj/ai-term-pick-project t) + (should (= fetches 1)) + (should (equal received-sessions '("other")))))) + +(provide 'test-ai-term--session-threading) +;;; test-ai-term--session-threading.el ends here diff --git a/tests/test-ai-term--show-or-create.el b/tests/test-ai-term--show-or-create.el index 9574b8a6..64e37653 100644 --- a/tests/test-ai-term--show-or-create.el +++ b/tests/test-ai-term--show-or-create.el @@ -122,7 +122,8 @@ dashboard put and letting the alist place agent into a fresh split. This test stubs `eat' to mimic the same-window side-effect and asserts the originally-selected window still shows its original buffer afterward." (let ((agent-name "agent [preserve-window-test]") - (orig-name "*test-original-buffer*")) + (orig-name "*test-original-buffer*") + (subprocess-calls nil)) (test-ai-term--cleanup agent-name) (when (get-buffer orig-name) (kill-buffer orig-name)) (unwind-protect @@ -138,9 +139,21 @@ originally-selected window still shows its original buffer afterward." (set-window-buffer (selected-window) buf) buf))) ((symbol-function 'cj/--ai-term-send-string) - (lambda (_buf _s) nil))) + (lambda (_buf _s) nil)) + ;; Same hermetic seams the shared macro mocks: no tmux + ;; subprocess for the fresh-session check, no /color timer. + ((symbol-function 'cj/--ai-term-live-tmux-sessions) + (lambda () nil)) + ((symbol-function 'cj/--ai-term-schedule-color) + (lambda (_buffer _color) nil)) + ;; Leak guard: any subprocess attempt is recorded, not run. + ;; `cj/--ai-term-live-tmux-sessions' swallows errors, so a + ;; signaling barrier would pass silently -- record and assert. + ((symbol-function 'process-file) + (lambda (&rest _) (push 'process-file subprocess-calls) -1))) (cj/--ai-term-show-or-create "/tmp/preserve" agent-name) - (should (eq (window-buffer orig-win) orig-buf))))) + (should (eq (window-buffer orig-win) orig-buf)) + (should-not subprocess-calls)))) (test-ai-term--cleanup agent-name) (when (get-buffer orig-name) (kill-buffer orig-name))))) diff --git a/tests/test-auto-dim-config.el b/tests/test-auto-dim-config.el index 12435fa0..8b13fbb0 100644 --- a/tests/test-auto-dim-config.el +++ b/tests/test-auto-dim-config.el @@ -30,11 +30,105 @@ (progn (should (bound-and-true-p auto-dim-other-buffers-mode)) (should (null auto-dim-other-buffers-dim-on-focus-out)) - (should (eq t auto-dim-other-buffers-dim-on-switch-to-minibuffer)) + ;; Config intent only: this asserts the value the module just set, so it + ;; cannot fail even if the fork inverts what the flag MEANS. The two + ;; behavioral tests below are what actually pin the behavior. + (should (null auto-dim-other-buffers-dim-on-switch-to-minibuffer)) (should-not (assq 'fringe auto-dim-other-buffers-affected-faces))) (when (fboundp 'auto-dim-other-buffers-mode) (auto-dim-other-buffers-mode -1)))) +(defmacro test-auto-dim--with-two-windows (win-a win-b &rest body) + "Bind WIN-A and WIN-B to two live windows with the mode on, then run BODY. +Restores the window configuration, the buffers, and the mode's PRIOR state. +Restoring rather than force-disabling matters: `auto-dim-other-buffers-mode' is +global, and switching it off unconditionally left a later test in this file +asserting the mode is on with it off. That only stayed hidden because ERT runs +tests alphabetically and the asserting test sorts first." + (declare (indent 2)) + `(let ((config (current-window-configuration)) + (was-on (bound-and-true-p auto-dim-other-buffers-mode))) + (unwind-protect + (let* ((,win-a (selected-window)) + (,win-b (split-window))) + (set-window-buffer ,win-a (get-buffer-create " *adob-a*")) + (set-window-buffer ,win-b (get-buffer-create " *adob-b*")) + (select-window ,win-a) + (auto-dim-other-buffers-mode 1) + ,@body) + (when (fboundp 'auto-dim-other-buffers-mode) + (auto-dim-other-buffers-mode (if was-on 1 -1))) + (set-window-configuration config) + (dolist (name '(" *adob-a*" " *adob-b*")) + (when (get-buffer name) (kill-buffer name)))))) + +(ert-deftest test-auto-dim-config-minibuffer-entry-leaves-previous-window-lit () + "Normal: with the flag nil, entering the minibuffer leaves the previous window lit. +This is the half that works, and the reason the flag is set to nil. + +Deliberately asserts the composite behavior rather than naming one function. +Selecting the minibuffer fires the mode's own hooks, so the observable outcome is +not attributable to the explicit `adob--update' call alone -- and the observable +outcome is what the setting promises the user. + +The `win-b' assertions are positive controls. Without them this test passes +against an implementation where dimming is broken everywhere, which looks +identical to the implementation being correct." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (test-auto-dim--with-two-windows win-a win-b + (adob--rescan-windows) + (should (null (window-parameter win-a 'adob--dim))) + (should (window-parameter win-b 'adob--dim)) + (select-window (minibuffer-window)) + (adob--update) + (should (null (window-parameter win-a 'adob--dim))) + (should (window-parameter win-b 'adob--dim)))) + +(ert-deftest test-auto-dim-config-minibuffer-entry-dims-when-flag-is-t () + "Boundary: with the flag t, entering the minibuffer DOES dim the previous window. +This is what gives the nil setting meaning. Without it the suite never shows the +flag changing anything, so the config assertion in +`test-auto-dim-config-applies-settings' has nothing standing behind it." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (test-auto-dim--with-two-windows win-a win-b + (let ((auto-dim-other-buffers-dim-on-switch-to-minibuffer t)) + (adob--rescan-windows) + (should (null (window-parameter win-a 'adob--dim))) + (select-window (minibuffer-window)) + (adob--update) + (should (window-parameter win-a 'adob--dim))))) + +(ert-deftest test-auto-dim-config-rescan-ignores-the-minibuffer-flag () + "Error: `adob--rescan-windows' dims everything on a minibuffer selection. +Known defect in the fork, pinned here rather than left undocumented. The +rescan is on `window-configuration-change-hook' and dims by window identity +alone -- and `(window-list nil \\='n)' excludes the minibuffer, so when the +minibuffer is selected nothing matches and every window dims. A completion +popup is the everyday case: `adob--update' honours the flag, this does not. + +Expected to fail until the fork honours the flag in the rescan too. When it +starts passing, ERT reports an unexpected pass -- that is the signal to drop +this test and stop treating the gap as open. + +The `win-b' positive control is load-bearing here. Three different broken +implementations -- dimming disabled everywhere, the rescan never setting the +parameter, `adob--update' made a no-op -- all produce an unexpected pass that +would otherwise read as \"the fork fixed it\". Asserting that `win-b' is still +dimmed separates a real fix from dimming having broken." + :expected-result :failed + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (test-auto-dim--with-two-windows win-a win-b + (adob--rescan-windows) + (should (null (window-parameter win-a 'adob--dim))) + (should (window-parameter win-b 'adob--dim)) + (select-window (minibuffer-window)) + (adob--rescan-windows) + (should (window-parameter win-b 'adob--dim)) + (should (null (window-parameter win-a 'adob--dim))))) + (defconst test-auto-dim--flat-dimmed-org-faces (append (mapcar (lambda (n) (intern (format "org-level-%d" n))) (number-sequence 1 8)) diff --git a/tests/test-browser-config--preferred-default.el b/tests/test-browser-config--preferred-default.el new file mode 100644 index 00000000..113ad540 --- /dev/null +++ b/tests/test-browser-config--preferred-default.el @@ -0,0 +1,89 @@ +;;; test-browser-config--preferred-default.el --- Tests for the first-run browser pick -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for cj/--preferred-default-browser, the pure helper that picks +;; the first-run default when no saved choice exists. +;; +;; The behavior it fixes: EWW is listed first in `cj/browser-definitions' and +;; carries a nil executable, so `cj/discover-browsers' always reports it as +;; available and it sorted first. A fresh machine therefore opened every org +;; link in the Emacs text browser until the user found cj/choose-browser, even +;; with Chrome or Firefox installed. The helper prefers a real external +;; browser and keeps EWW as the genuine last resort. +;; +;; The helper takes the discovered list as an argument rather than calling +;; `cj/discover-browsers' itself, so these tests drive real data structures +;; and never stub executable-find. +;; +;; Test organization: +;; - Normal Cases: external browser preferred over a leading built-in +;; - Boundary Cases: only built-ins, only externals, single entry, empty list +;; - Error Cases: entries missing the :executable key +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'browser-config) + +(defconst test-browser--eww + '(:executable nil :function eww-browse-url :name "EWW (Emacs Browser)" + :path nil :program-var nil)) + +(defconst test-browser--chrome + '(:executable "google-chrome" :function browse-url-chrome :name "Google Chrome" + :path "/usr/bin/google-chrome" :program-var browse-url-chrome-program)) + +(defconst test-browser--firefox + '(:executable "firefox" :function browse-url-firefox :name "Firefox" + :path "/usr/bin/firefox" :program-var browse-url-firefox-program)) + +;;; Normal Cases + +(ert-deftest test-browser-config-preferred-default-skips-leading-builtin () + "Normal: an installed external browser wins over a built-in listed first." + (should (equal (cj/--preferred-default-browser + (list test-browser--eww test-browser--chrome)) + test-browser--chrome))) + +(ert-deftest test-browser-config-preferred-default-keeps-external-order () + "Normal: the FIRST external in list order wins, not merely any external." + (should (equal (cj/--preferred-default-browser + (list test-browser--eww test-browser--chrome test-browser--firefox)) + test-browser--chrome))) + +;;; Boundary Cases + +(ert-deftest test-browser-config-preferred-default-builtin-only-falls-back () + "Boundary: with no external installed, the built-in is still chosen." + (should (equal (cj/--preferred-default-browser (list test-browser--eww)) + test-browser--eww))) + +(ert-deftest test-browser-config-preferred-default-external-only () + "Boundary: a list of externals returns the first one." + (should (equal (cj/--preferred-default-browser + (list test-browser--firefox test-browser--chrome)) + test-browser--firefox))) + +(ert-deftest test-browser-config-preferred-default-empty-list-is-nil () + "Boundary: an empty discovery result yields nil, never an error." + (should (null (cj/--preferred-default-browser '())))) + +(ert-deftest test-browser-config-preferred-default-single-builtin () + "Boundary: a one-element built-in list returns that element." + (should (equal (cj/--preferred-default-browser (list test-browser--eww)) + test-browser--eww))) + +;;; Error Cases + +(ert-deftest test-browser-config-preferred-default-missing-executable-key () + "Error: a plist with no :executable key counts as built-in, not a crash." + (let ((malformed '(:name "Odd" :function ignore))) + (should (equal (cj/--preferred-default-browser + (list malformed test-browser--chrome)) + test-browser--chrome)) + (should (equal (cj/--preferred-default-browser (list malformed)) + malformed)))) + +(provide 'test-browser-config--preferred-default) +;;; test-browser-config--preferred-default.el ends here diff --git a/tests/test-calendar-sync--apply-recurrence-exceptions.el b/tests/test-calendar-sync--apply-recurrence-exceptions.el index 7711c5cb..999296fb 100644 --- a/tests/test-calendar-sync--apply-recurrence-exceptions.el +++ b/tests/test-calendar-sync--apply-recurrence-exceptions.el @@ -153,5 +153,36 @@ NEW-* values are the rescheduled time." (and (= 1 (length result)) (= 9 (nth 3 (plist-get (car result) :start))))))))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--apply-recurrence-exceptions-normal-cancelled-removes () + "Normal: a cancelled exception removes its occurrence instead of overriding it." + (let* ((occurrences (list (test-make-occurrence 2026 2 3 9 0 "Weekly Meeting") + (test-make-occurrence 2026 2 10 9 0 "Weekly Meeting") + (test-make-occurrence 2026 2 17 9 0 "Weekly Meeting"))) + (exceptions (make-hash-table :test 'equal))) + ;; Feb 10 is cancelled. + (puthash "test-event@google.com" + (list (append (test-make-exception-data 2026 2 10 9 0 2026 2 10 9 0) + '(:cancelled t))) + exceptions) + (let ((result (calendar-sync--apply-recurrence-exceptions occurrences exceptions))) + (should (= 2 (length result))) + ;; Feb 3 and Feb 17 remain; Feb 10 is gone. + (should (equal '(3 17) + (mapcar (lambda (occ) (nth 2 (plist-get occ :start))) result)))))) + +(ert-deftest test-calendar-sync--apply-recurrence-exceptions-boundary-cancelled-no-match-keeps-all () + "Boundary: a cancelled exception that matches nothing removes nothing." + (let* ((occurrences (list (test-make-occurrence 2026 2 3 9 0 "Weekly Meeting"))) + (exceptions (make-hash-table :test 'equal))) + ;; Cancelled exception targets a different date. + (puthash "test-event@google.com" + (list (append (test-make-exception-data 2026 3 3 9 0 2026 3 3 9 0) + '(:cancelled t))) + exceptions) + (let ((result (calendar-sync--apply-recurrence-exceptions occurrences exceptions))) + (should (= 1 (length result)))))) + (provide 'test-calendar-sync--apply-recurrence-exceptions) ;;; test-calendar-sync--apply-recurrence-exceptions.el ends here diff --git a/tests/test-calendar-sync--expand-monthly.el b/tests/test-calendar-sync--expand-monthly.el index 3dc1f2dc..e9fae901 100644 --- a/tests/test-calendar-sync--expand-monthly.el +++ b/tests/test-calendar-sync--expand-monthly.el @@ -14,9 +14,12 @@ ;;; Normal Cases (ert-deftest test-calendar-sync--expand-monthly-normal-generates-occurrences () - "Test expanding monthly event generates occurrences within range." - (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) - (end-date (test-calendar-sync-time-days-from-now 1 11 0)) + "Test expanding monthly event generates occurrences within range. +Anchored on a day every month has: a series on the 29th, 30th, or 31st +correctly skips the months lacking that day, which is fewer than one per month +and not what this assertion is about." + (let* ((start-date (test-calendar-sync-time-monthly-anchor 10 0)) + (end-date (test-calendar-sync-time-monthly-anchor 11 0)) (base-event (list :summary "Monthly Review" :start start-date :end end-date)) @@ -28,9 +31,13 @@ (should (< (length occurrences) 20)))) (ert-deftest test-calendar-sync--expand-monthly-normal-preserves-day-of-month () - "Test that each occurrence falls on the same day of month." - (let* ((start-date (test-calendar-sync-time-days-from-now 5 10 0)) - (end-date (test-calendar-sync-time-days-from-now 5 11 0)) + "Test that each occurrence falls on the same day of month. +Anchored on a day every month has, so the assertion below can be an equality. +It used to be `<=' against an anchor whose day varied with the run date, which a +skipped month satisfies without ever landing on the right day -- the assertion +held even when the series was wrong." + (let* ((start-date (test-calendar-sync-time-monthly-anchor 10 0)) + (end-date (test-calendar-sync-time-monthly-anchor 11 0)) (expected-day (nth 2 start-date)) (base-event (list :summary "Monthly" :start start-date @@ -39,15 +46,15 @@ (range (test-calendar-sync-wide-range)) (occurrences (calendar-sync--expand-monthly base-event rrule range))) (should (> (length occurrences) 0)) - ;; Day of month should be consistent (may clamp for short months) + ;; Every occurrence lands on the anchor day, exactly. (dolist (occ occurrences) (let ((day (nth 2 (plist-get occ :start)))) - (should (<= day expected-day)))))) + (should (= day expected-day)))))) (ert-deftest test-calendar-sync--expand-monthly-normal-interval-two () "Test expanding bi-monthly event." - (let* ((start-date (test-calendar-sync-time-days-from-now 1 9 0)) - (end-date (test-calendar-sync-time-days-from-now 1 10 0)) + (let* ((start-date (test-calendar-sync-time-monthly-anchor 9 0)) + (end-date (test-calendar-sync-time-monthly-anchor 10 0)) (base-event (list :summary "Bi-Monthly" :start start-date :end end-date)) @@ -170,5 +177,124 @@ (occurrences (calendar-sync--expand-monthly base-event rrule range))) (should (= (length occurrences) 3)))) +;;; BYDAY (nth weekday) Cases +;; +;; Fixed dates are deterministic here: the expansion range is an explicit +;; parameter, not derived from the current time, so these never age out. + +(defun test-calendar-sync--expand-monthly-range-2026 () + "Fixed expansion range covering calendar year 2026." + (list (encode-time 0 0 0 1 1 2026) (encode-time 0 0 0 31 12 2026))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-second-wednesday () + "Normal: BYDAY=2WE lands on the 2nd Wednesday of each month, not the +day-of-month of DTSTART. This is the live Craig/Ryan series shape." + (let* ((base-event (list :summary "2nd Wednesday" + :start '(2026 1 14 10 0) + :end '(2026 1 14 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("2WE"))) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + (should (equal days '((1 14) (2 11) (3 11) (4 8) (5 13) (6 10) + (7 8) (8 12) (9 9) (10 14) (11 11) (12 9)))) + ;; Every occurrence is a Wednesday (weekday 3), never a fixed day-of-month. + (dolist (occ occurrences) + (let ((s (plist-get occ :start))) + (should (= 3 (calendar-sync--date-weekday + (list (nth 0 s) (nth 1 s) (nth 2 s))))))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-last-tuesday () + "Normal: BYDAY=-1TU lands on the last Tuesday of each month." + (let* ((base-event (list :summary "Last Tuesday" + :start '(2026 1 27 9 0) + :end '(2026 1 27 10 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("-1TU") :count 3)) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + (should (equal days '((1 27) (2 24) (3 31)))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-bysetpos-second-sunday () + "Normal: BYDAY=SU with BYSETPOS=2 lands on the 2nd Sunday (Proton shape)." + (let* ((base-event (list :summary "2nd Sunday" + :start '(2026 1 11 8 0) + :end '(2026 1 11 9 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("SU") :bysetpos 2 :count 3)) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + (should (equal days '((1 11) (2 8) (3 8)))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-until-inclusive-and-reached () + "Boundary: with BYDAY, UNTIL is inclusive and the series reaches it. +Upper bound alone can't catch a dropped final occurrence -- assert both." + (let* ((base-event (list :summary "Bounded" + :start '(2026 1 14 10 0) + :end '(2026 1 14 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("2WE") + :until '(2026 5 13))) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (last-start (plist-get (car (last occurrences)) :start))) + (should (= (length occurrences) 5)) + ;; Reach: the occurrence landing exactly on UNTIL is kept. + (should (equal (list (nth 0 last-start) (nth 1 last-start) (nth 2 last-start)) + '(2026 5 13))))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-count-limits () + "Boundary: COUNT caps a BYDAY series." + (let* ((base-event (list :summary "Counted" + :start '(2026 1 14 10 0) + :end '(2026 1 14 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("2WE") :count 4)) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range))) + (should (= (length occurrences) 4)))) + +(ert-deftest test-calendar-sync--expand-monthly-byday-fifth-weekday-skips-short-months () + "Boundary: BYDAY=5WE only lands in months that have a 5th Wednesday." + (let* ((base-event (list :summary "5th Wednesday" + :start '(2026 4 29 10 0) + :end '(2026 4 29 11 0))) + (rrule (list :freq 'monthly :interval 1 :byday '("5WE"))) + (range (test-calendar-sync--expand-monthly-range-2026)) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 1 s) (nth 2 s)))) + occurrences))) + ;; 2026 months (Apr on) with a 5th Wednesday: Apr 29, Jul 29, Sep 30, Dec 30. + (should (equal days '((4 29) (7 29) (9 30) (12 30)))))) + +(ert-deftest test-calendar-sync--expand-monthly-on-31st-skips-short-months () + "Boundary: a plain monthly rule on the 31st skips months without a 31st. +The stepper kept day-of-month verbatim, so Jan 31 stepped to Feb 31, +which encode-time normalizes to Mar 3 -- phantom mis-dated occurrences +instead of the RFC 5545 skip." + (let* ((base-event (list :summary "Monthly on the 31st" + :start '(2030 1 31 10 0) + :end '(2030 1 31 11 0))) + (rrule (list :freq 'monthly :interval 1)) + ;; End the range past Dec 31: the range end is midnight, so ending + ;; ON the 31st would exclude that day's 10:00 occurrence. + (range (list (calendar-sync--date-to-time '(2030 1 1)) + (calendar-sync--date-to-time '(2031 1 1)))) + (occurrences (calendar-sync--expand-monthly base-event rrule range)) + (months (mapcar (lambda (o) (nth 1 (plist-get o :start))) occurrences)) + (days (mapcar (lambda (o) (nth 2 (plist-get o :start))) occurrences))) + ;; Only the seven 31-day months of 2030, each on the 31st. + (should (equal months '(1 3 5 7 8 10 12))) + (should (equal days '(31 31 31 31 31 31 31))))) + (provide 'test-calendar-sync--expand-monthly) ;;; test-calendar-sync--expand-monthly.el ends here diff --git a/tests/test-calendar-sync--expand-yearly.el b/tests/test-calendar-sync--expand-yearly.el index ad9b8f27..c636e54a 100644 --- a/tests/test-calendar-sync--expand-yearly.el +++ b/tests/test-calendar-sync--expand-yearly.el @@ -175,5 +175,31 @@ (occurrences (calendar-sync--expand-yearly base-event rrule range))) (should (= (length occurrences) 2)))) +;;; BYMONTH + BYDAY (nth weekday) Cases +;; +;; Fixed dates are deterministic here: the expansion range is an explicit +;; parameter, not derived from the current time. + +(ert-deftest test-calendar-sync--expand-yearly-bymonth-byday-nth-weekday () + "Normal: FREQ=YEARLY;BYMONTH=3;BYDAY=2SU tracks the 2nd Sunday of March +each year (the DST clock-change shape), not DTSTART's calendar date." + (let* ((base-event (list :summary "Clocks change" + :start '(2026 3 8 2 0) + :end '(2026 3 8 3 0))) + (rrule (list :freq 'yearly :interval 1 :bymonth 3 :byday '("2SU"))) + (range (list (encode-time 0 0 0 1 1 2026) + (encode-time 0 0 0 31 12 2027))) + (occurrences (calendar-sync--expand-yearly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 0 s) (nth 1 s) (nth 2 s)))) + occurrences))) + ;; 2nd Sunday of March: 2026-03-08, 2027-03-14 -- different day-of-month. + (should (equal days '((2026 3 8) (2027 3 14)))) + (dolist (occ occurrences) + (let ((s (plist-get occ :start))) + (should (= 7 (calendar-sync--date-weekday + (list (nth 0 s) (nth 1 s) (nth 2 s))))))))) + (provide 'test-calendar-sync--expand-yearly) ;;; test-calendar-sync--expand-yearly.el ends here diff --git a/tests/test-calendar-sync--nth-weekday-of-month.el b/tests/test-calendar-sync--nth-weekday-of-month.el new file mode 100644 index 00000000..afb0bd35 --- /dev/null +++ b/tests/test-calendar-sync--nth-weekday-of-month.el @@ -0,0 +1,67 @@ +;;; test-calendar-sync--nth-weekday-of-month.el --- Tests for calendar-sync--nth-weekday-of-month -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the nth-weekday-of-month helper backing monthly/yearly BYDAY +;; expansion. Fixed dates are safe here: the function is pure calendar +;; arithmetic with no relation to the current time. + +;;; Code: + +(require 'ert) +(require 'calendar-sync) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-second-wednesday () + "Normal: 2nd Wednesday of Jan 2026 is the 14th." + ;; Jan 2026: Jan 1 is a Thursday; Wednesdays fall on 7, 14, 21, 28. + (should (= (calendar-sync--nth-weekday-of-month 2026 1 3 2) 14))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-first-monday () + "Normal: 1st Monday of Feb 2026 is the 2nd." + ;; Feb 2026: Feb 1 is a Sunday; Mondays fall on 2, 9, 16, 23. + (should (= (calendar-sync--nth-weekday-of-month 2026 2 1 1) 2))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-last-tuesday () + "Normal: last Tuesday of Mar 2026 is the 31st (negative ordinal)." + ;; Mar 2026: Tuesdays fall on 3, 10, 17, 24, 31. + (should (= (calendar-sync--nth-weekday-of-month 2026 3 2 -1) 31))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-second-to-last-friday () + "Normal: -2 ordinal picks the second-to-last Friday." + ;; May 2026: Fridays fall on 1, 8, 15, 22, 29. + (should (= (calendar-sync--nth-weekday-of-month 2026 5 5 -2) 22))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-fifth-occurrence-exists () + "Boundary: 5th Friday exists in May 2026." + (should (= (calendar-sync--nth-weekday-of-month 2026 5 5 5) 29))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-fifth-occurrence-missing () + "Boundary: 5th Wednesday of Feb 2026 does not exist -- returns nil." + ;; Feb 2026 has four Wednesdays (4, 11, 18, 25). + (should (null (calendar-sync--nth-weekday-of-month 2026 2 3 5)))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-first-day-is-target () + "Boundary: the 1st of the month itself is the 1st occurrence." + ;; Apr 2026: Apr 1 is a Wednesday. + (should (= (calendar-sync--nth-weekday-of-month 2026 4 3 1) 1))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-leap-february () + "Boundary: leap-year February (2028) handled -- last Tuesday is the 29th." + ;; Feb 2028: Feb 29 exists and is a Tuesday. + (should (= (calendar-sync--nth-weekday-of-month 2028 2 2 -1) 29))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-error-zero-ordinal-nil () + "Error: ordinal 0 is meaningless -- returns nil." + (should (null (calendar-sync--nth-weekday-of-month 2026 1 3 0)))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-error-out-of-range-negative-nil () + "Error: -6th occurrence never exists in a month -- returns nil." + (should (null (calendar-sync--nth-weekday-of-month 2026 1 3 -6)))) + +(provide 'test-calendar-sync--nth-weekday-of-month) +;;; test-calendar-sync--nth-weekday-of-month.el ends here diff --git a/tests/test-calendar-sync--parse-byday-entry.el b/tests/test-calendar-sync--parse-byday-entry.el new file mode 100644 index 00000000..4a9b4ef5 --- /dev/null +++ b/tests/test-calendar-sync--parse-byday-entry.el @@ -0,0 +1,41 @@ +;;; test-calendar-sync--parse-byday-entry.el --- Tests for calendar-sync--parse-byday-entry -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for parsing a single RRULE BYDAY entry ("2WE", "-1TU", "SU") into +;; an (ordinal . weekday-number) cons. Ordinal is nil for a bare weekday. + +;;; Code: + +(require 'ert) +(require 'calendar-sync) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-positive-ordinal () + "Normal: \"2WE\" parses to ordinal 2, Wednesday (3)." + (should (equal (calendar-sync--parse-byday-entry "2WE") '(2 . 3)))) + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-negative-ordinal () + "Normal: \"-1TU\" parses to ordinal -1, Tuesday (2)." + (should (equal (calendar-sync--parse-byday-entry "-1TU") '(-1 . 2)))) + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-bare-weekday () + "Normal: \"SU\" parses to nil ordinal, Sunday (7)." + (should (equal (calendar-sync--parse-byday-entry "SU") '(nil . 7)))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-boundary-double-digit-ordinal () + "Boundary: \"53MO\" (yearly-scale ordinal) parses without truncation." + (should (equal (calendar-sync--parse-byday-entry "53MO") '(53 . 1)))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-error-garbage-nil () + "Error: an unrecognizable entry returns nil." + (should (null (calendar-sync--parse-byday-entry "XX"))) + (should (null (calendar-sync--parse-byday-entry ""))) + (should (null (calendar-sync--parse-byday-entry nil)))) + +(provide 'test-calendar-sync--parse-byday-entry) +;;; test-calendar-sync--parse-byday-entry.el ends here diff --git a/tests/test-calendar-sync--parse-event.el b/tests/test-calendar-sync--parse-event.el index 9c343db2..b3f58ba2 100644 --- a/tests/test-calendar-sync--parse-event.el +++ b/tests/test-calendar-sync--parse-event.el @@ -78,5 +78,37 @@ (let ((vevent "BEGIN:VEVENT\nSUMMARY:Orphan\nEND:VEVENT")) (should (null (calendar-sync--parse-event vevent))))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--parse-event-error-cancelled-returns-nil () + "Error: a STATUS:CANCELLED event returns nil -- cancelled events don't render." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Cancelled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:CANCELLED\n" + "END:VEVENT"))) + (should (null (calendar-sync--parse-event vevent))))) + +(ert-deftest test-calendar-sync--parse-event-boundary-cancelled-case-insensitive () + "Boundary: STATUS value matching is case-insensitive." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Cancelled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:Cancelled\n" + "END:VEVENT"))) + (should (null (calendar-sync--parse-event vevent))))) + +(ert-deftest test-calendar-sync--parse-event-normal-confirmed-still-parses () + "Normal: STATUS:CONFIRMED events still parse." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Confirmed Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:CONFIRMED\n" + "END:VEVENT"))) + (should (calendar-sync--parse-event vevent)))) + (provide 'test-calendar-sync--parse-event) ;;; test-calendar-sync--parse-event.el ends here diff --git a/tests/test-calendar-sync--parse-exception-event.el b/tests/test-calendar-sync--parse-exception-event.el index a26a7418..1c9411f3 100644 --- a/tests/test-calendar-sync--parse-exception-event.el +++ b/tests/test-calendar-sync--parse-exception-event.el @@ -82,5 +82,33 @@ than a half-built plist." "END:VEVENT"))) (should-not (calendar-sync--parse-exception-event event)))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--parse-exception-event-normal-cancelled-flag () + "Normal: a STATUS:CANCELLED override carries :cancelled t, so the +matching occurrence can be removed rather than overridden." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (event (concat "BEGIN:VEVENT\n" + "UID:override@google.com\n" + "RECURRENCE-ID:20260203T090000Z\n" + "SUMMARY:Craig / Ryan\n" + "STATUS:CANCELLED\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "DTEND:" (test-calendar-sync-ics-datetime end) "\n" + "END:VEVENT")) + (plist (calendar-sync--parse-exception-event event))) + (should plist) + (should (plist-get plist :cancelled)))) + +(ert-deftest test-calendar-sync--parse-exception-event-boundary-no-status-not-cancelled () + "Boundary: an override without STATUS is not cancelled." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (plist (calendar-sync--parse-exception-event + (test-cs-parse-exc--override-event start end)))) + (should plist) + (should-not (plist-get plist :cancelled)))) + (provide 'test-calendar-sync--parse-exception-event) ;;; test-calendar-sync--parse-exception-event.el ends here diff --git a/tests/test-calendar-sync--parse-rrule.el b/tests/test-calendar-sync--parse-rrule.el index 099e4e44..2668c1ac 100644 --- a/tests/test-calendar-sync--parse-rrule.el +++ b/tests/test-calendar-sync--parse-rrule.el @@ -206,5 +206,26 @@ (should (= (plist-get result :count) 10))) (test-calendar-sync--parse-rrule-teardown))) +;;; BYSETPOS / BYMONTH Cases + +(ert-deftest test-calendar-sync--parse-rrule-normal-bysetpos-returns-number () + "Normal: BYSETPOS parses to a number (Proton emits BYDAY=SU;BYSETPOS=2)." + (let ((result (calendar-sync--parse-rrule "FREQ=MONTHLY;BYDAY=SU;BYSETPOS=2"))) + (should (eq (plist-get result :freq) 'monthly)) + (should (equal (plist-get result :byday) '("SU"))) + (should (= (plist-get result :bysetpos) 2)))) + +(ert-deftest test-calendar-sync--parse-rrule-normal-bymonth-returns-number () + "Normal: BYMONTH parses to a number (yearly nth-weekday rules carry it)." + (let ((result (calendar-sync--parse-rrule "FREQ=YEARLY;BYMONTH=3;BYDAY=2SU"))) + (should (eq (plist-get result :freq) 'yearly)) + (should (= (plist-get result :bymonth) 3)) + (should (equal (plist-get result :byday) '("2SU"))))) + +(ert-deftest test-calendar-sync--parse-rrule-boundary-negative-bysetpos () + "Boundary: negative BYSETPOS (last matching day) parses." + (let ((result (calendar-sync--parse-rrule "FREQ=MONTHLY;BYDAY=FR;BYSETPOS=-1"))) + (should (= (plist-get result :bysetpos) -1)))) + (provide 'test-calendar-sync--parse-rrule) ;;; test-calendar-sync--parse-rrule.el ends here diff --git a/tests/test-calendar-sync--syncing-p.el b/tests/test-calendar-sync--syncing-p.el index b346bf77..df8bcd52 100644 --- a/tests/test-calendar-sync--syncing-p.el +++ b/tests/test-calendar-sync--syncing-p.el @@ -4,81 +4,111 @@ ;; Unit tests for `calendar-sync--syncing-p' (the per-calendar in-flight check ;; that lets the dispatcher skip an overlapping timer tick) and for the ;; load-state sanitize that clears a stale `syncing' status in a fresh process. +;; +;; Every test runs inside `test-cs-syncing--with-fresh-state', which let-binds +;; a private state hash. These tests previously cleared the module's global +;; hash on entry and left whatever they wrote in it on exit, which leaked: +;; `...-sync-calendar-skips-when-in-flight' marks "proton" as syncing to +;; exercise the guard, and `test-calendar-sync--sync-dispatch-normal-ics-fetcher' +;; in the sibling dispatch file dispatches a calendar also named "proton". +;; ERT runs them in that order, so the leftover in-flight status made the +;; dispatch a no-op and the sibling failed -- but only when the calendar-sync +;; files ran in one process. `make test' runs each file separately and the +;; editor hook skipped this family for being over its file cap, so nothing +;; caught it. Let-binding is what the sibling files already do +;; (test-calendar-sync.el, test-calendar-sync-async-worker.el); this file was +;; the odd one out. ;;; Code: (require 'ert) (require 'calendar-sync) -(defun test-cs-syncing--reset () - "Clear the module's per-calendar state hash." - (clrhash calendar-sync--calendar-states)) +(defmacro test-cs-syncing--with-fresh-state (&rest body) + "Run BODY with a private, empty per-calendar state hash. +Let-bound rather than cleared in place, so nothing this test writes can +reach a later test." + (declare (indent 0)) + `(let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + ,@body)) ;;; calendar-sync--syncing-p (ert-deftest test-calendar-sync--syncing-p-normal-true-when-syncing () "Normal: a calendar whose status is `syncing' reads as in-flight." - (test-cs-syncing--reset) - (calendar-sync--set-calendar-state "google" '(:status syncing)) - (should (calendar-sync--syncing-p "google"))) + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "google" '(:status syncing)) + (should (calendar-sync--syncing-p "google")))) (ert-deftest test-calendar-sync--syncing-p-boundary-nil-when-no-state () "Boundary: a calendar with no recorded state is not in-flight." - (test-cs-syncing--reset) - (should-not (calendar-sync--syncing-p "never-seen"))) + (test-cs-syncing--with-fresh-state + (should-not (calendar-sync--syncing-p "never-seen")))) (ert-deftest test-calendar-sync--syncing-p-error-nil-for-terminal-status () "Error: a terminal status (ok / error) is not in-flight." - (test-cs-syncing--reset) - (calendar-sync--set-calendar-state "google" '(:status ok)) - (should-not (calendar-sync--syncing-p "google")) - (calendar-sync--set-calendar-state "proton" '(:status error)) - (should-not (calendar-sync--syncing-p "proton"))) + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "google" '(:status ok)) + (should-not (calendar-sync--syncing-p "google")) + (calendar-sync--set-calendar-state "proton" '(:status error)) + (should-not (calendar-sync--syncing-p "proton")))) ;;; Dispatcher guard: an in-flight calendar skips both leaf syncers (ert-deftest test-calendar-sync--sync-calendar-skips-when-in-flight () "Normal: `calendar-sync--sync-calendar' does not launch a second sync for a calendar already marked syncing, so an overlapping timer tick is a no-op." - (test-cs-syncing--reset) - (let ((api-calls '()) (ics-calls '())) - (cl-letf (((symbol-function 'calendar-sync--sync-calendar-api) - (lambda (cal) (push cal api-calls))) - ((symbol-function 'calendar-sync--sync-calendar-ics) - (lambda (cal) (push cal ics-calls)))) - (calendar-sync--set-calendar-state "proton" '(:status syncing)) - (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" - :file "/tmp/c.org")) - (should (null api-calls)) - (should (null ics-calls))))) + (test-cs-syncing--with-fresh-state + (let ((api-calls '()) (ics-calls '())) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-api) + (lambda (cal) (push cal api-calls))) + ((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) (push cal ics-calls)))) + (calendar-sync--set-calendar-state "proton" '(:status syncing)) + (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" + :file "/tmp/c.org")) + (should (null api-calls)) + (should (null ics-calls)))))) (ert-deftest test-calendar-sync--sync-calendar-dispatches-when-idle () "Boundary: an idle calendar (no in-flight status) still dispatches normally." - (test-cs-syncing--reset) - (let ((ics-calls '())) - (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) - (lambda (cal) (push cal ics-calls)))) - (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" - :file "/tmp/c.org")) - (should (= 1 (length ics-calls)))))) + (test-cs-syncing--with-fresh-state + (let ((ics-calls '())) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) (push cal ics-calls)))) + (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" + :file "/tmp/c.org")) + (should (= 1 (length ics-calls))))))) + +;;; Isolation guard + +(ert-deftest test-calendar-sync--syncing-state-does-not-leak () + "Error: state written inside the macro is gone once it returns. +Pins the isolation itself. Without it a test marking a calendar syncing +leaves that status set for every later test in the same process, which is +exactly what broke the sibling dispatch test." + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "leak-probe" '(:status syncing)) + (should (calendar-sync--syncing-p "leak-probe"))) + (should-not (calendar-sync--syncing-p "leak-probe"))) ;;; load-state sanitize: a persisted `syncing' status is cleared on load (ert-deftest test-calendar-sync--load-state-clears-stale-syncing () "Error: a `syncing' status persisted before a crash is reset on load, so the in-flight guard cannot skip that calendar forever in the new session." - (test-cs-syncing--reset) - (let* ((dir (make-temp-file "cs-state-" t)) - (calendar-sync--state-file (expand-file-name "state.el" dir))) - (unwind-protect - (progn - (with-temp-file calendar-sync--state-file - (prin1 '((timezone-offset . nil) - (calendar-states . (("google" . (:status syncing))))) - (current-buffer))) - (calendar-sync--load-state) - (should-not (calendar-sync--syncing-p "google"))) - (delete-directory dir t)))) + (test-cs-syncing--with-fresh-state + (let* ((dir (make-temp-file "cs-state-" t)) + (calendar-sync--state-file (expand-file-name "state.el" dir))) + (unwind-protect + (progn + (with-temp-file calendar-sync--state-file + (prin1 '((timezone-offset . nil) + (calendar-states . (("google" . (:status syncing))))) + (current-buffer))) + (calendar-sync--load-state) + (should-not (calendar-sync--syncing-p "google"))) + (delete-directory dir t))))) (provide 'test-calendar-sync--syncing-p) ;;; test-calendar-sync--syncing-p.el ends here diff --git a/tests/test-calendar-sync.el b/tests/test-calendar-sync.el index f562cfc6..8a7c2549 100644 --- a/tests/test-calendar-sync.el +++ b/tests/test-calendar-sync.el @@ -713,5 +713,50 @@ Valid events should be parsed, invalid ones skipped." (should-not (and org-content (string-match-p "OutOfRangeEvent" org-content))))) +;;; calendar-sync--sync-timer-function — hourly-timer body hygiene + +(ert-deftest test-calendar-sync-timer-function-does-not-propagate-a-signal () + "Error: a signal in the timer body is caught, not propagated. +The function runs from an hourly `run-at-time' timer. An unguarded signal +in the timezone check or the sync fan-out would error on every tick — the +same error, once an hour, forever. It must swallow-and-log instead." + (cl-letf (((symbol-function 'calendar-sync--timezone-changed-p) + (lambda (&rest _) (error "boom from the timezone check"))) + ((symbol-function 'calendar-sync--sync-all-calendars) #'ignore) + ((symbol-function 'calendar-sync--log-silently) #'ignore)) + ;; Must return normally rather than signal. + (should (progn (calendar-sync--sync-timer-function) t)))) + +(ert-deftest test-calendar-sync-timer-function-signal-in-sync-is-caught () + "Error: a signal from the sync fan-out is also caught, not propagated." + (cl-letf (((symbol-function 'calendar-sync--timezone-changed-p) #'ignore) + ((symbol-function 'calendar-sync--sync-all-calendars) + (lambda (&rest _) (error "boom from sync-all"))) + ((symbol-function 'calendar-sync--log-silently) #'ignore)) + (should (progn (calendar-sync--sync-timer-function) t)))) + +(ert-deftest test-calendar-sync-timer-function-timezone-change-is-not-echoed () + "Normal: a detected timezone change is logged silently, not echoed. +An hourly timer that calls `message' spams the echo area; the notice belongs +in the silent log like the module's other timer-path notices." + (let (silent-logged echoed) + (cl-letf (((symbol-function 'calendar-sync--timezone-changed-p) + (lambda (&rest _) t)) + ((symbol-function 'calendar-sync--format-timezone-offset) + (lambda (&rest _) "UTC+0")) + ((symbol-function 'calendar-sync--current-timezone-offset) + (lambda (&rest _) 0)) + ((symbol-function 'calendar-sync--sync-all-calendars) #'ignore) + ((symbol-function 'calendar-sync--log-silently) + (lambda (fmt &rest _) (when (string-match-p "Timezone" fmt) + (setq silent-logged t)))) + ((symbol-function 'message) + (lambda (fmt &rest _) (when (and (stringp fmt) + (string-match-p "Timezone" fmt)) + (setq echoed t))))) + (calendar-sync--sync-timer-function) + (should silent-logged) + (should-not echoed)))) + (provide 'test-calendar-sync) ;;; test-calendar-sync.el ends here diff --git a/tests/test-calibredb-epub-config--epub-mode.el b/tests/test-calibredb-epub-config--epub-mode.el new file mode 100644 index 00000000..a65bdabf --- /dev/null +++ b/tests/test-calibredb-epub-config--epub-mode.el @@ -0,0 +1,70 @@ +;;; test-calibredb-epub-config--epub-mode.el --- Tests for epub mode resolution -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests that .epub files reach nov-mode through `auto-mode-alist' alone, with +;; no advice on `set-auto-mode'. +;; +;; Background: the module used to carry an :around advice on `set-auto-mode' +;; forcing nov-mode for .epub, added to keep `magic-fallback-mode-alist' from +;; opening the zip container in archive-mode. It was never needed. +;; `set-auto-mode' consults `auto-mode-alist' before `magic-fallback-mode-alist', +;; and nov's use-package :mode registers "\\.epub\\'" there, so the alist +;; already won. Verified live on the daemon: a real zip-format .epub opened in +;; nov-mode both with the advice and with it removed. +;; +;; The advice was not free. `set-auto-mode' runs on every file visit, so the +;; advice put a redundant frame and an extra failure surface on the path for +;; every file of every type. +;; +;; The second test is a regression guard: it fails if the advice is ever +;; reinstated, which is the mistake this cleanup exists to prevent. +;; +;; Test organization: +;; - Normal Cases: .epub resolves to nov-mode; no advice on set-auto-mode +;; - Boundary Cases: a path merely containing "epub", and a bare "epub" name +;; - Error Cases: an unrelated extension does not resolve to nov-mode +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calibredb-epub-config) + +(defun test-epub-mode--resolve (filename) + "Return the major mode `auto-mode-alist' assigns to FILENAME." + (assoc-default filename auto-mode-alist 'string-match)) + +;;; Normal Cases + +(ert-deftest test-calibredb-epub-config-epub-resolves-to-nov-mode () + "Normal: auto-mode-alist maps a .epub file to nov-mode on its own." + (should (eq 'nov-mode (test-epub-mode--resolve "book.epub")))) + +(ert-deftest test-calibredb-epub-config-no-set-auto-mode-advice () + "Normal: nothing advises set-auto-mode to force nov-mode. +Regression guard. auto-mode-alist already wins over +magic-fallback-mode-alist, so an advice here would be redundant work on +every file visit." + (should-not (advice-member-p 'cj/force-nov-mode-for-epub 'set-auto-mode)) + (should-not (fboundp 'cj/force-nov-mode-for-epub))) + +;;; Boundary Cases + +(ert-deftest test-calibredb-epub-config-epub-in-directory-name () + "Boundary: the extension anchors at the end, so a directory named epub +does not by itself select nov-mode." + (should-not (eq 'nov-mode (test-epub-mode--resolve "/home/user/epub/notes.txt")))) + +(ert-deftest test-calibredb-epub-config-epub-with-path () + "Boundary: a full path with directories still resolves on the extension." + (should (eq 'nov-mode (test-epub-mode--resolve "/home/user/books/a b.epub")))) + +;;; Error Cases + +(ert-deftest test-calibredb-epub-config-other-extension-not-nov () + "Error: an unrelated extension must not resolve to nov-mode." + (should-not (eq 'nov-mode (test-epub-mode--resolve "archive.zip"))) + (should-not (eq 'nov-mode (test-epub-mode--resolve "notes.org")))) + +(provide 'test-calibredb-epub-config--epub-mode) +;;; test-calibredb-epub-config--epub-mode.el ends here diff --git a/tests/test-calibredb-epub-config.el b/tests/test-calibredb-epub-config.el index 71581d4c..7afc58f3 100644 --- a/tests/test-calibredb-epub-config.el +++ b/tests/test-calibredb-epub-config.el @@ -285,57 +285,6 @@ so the search buffer rebuilds against the now-unfiltered set." (cj/calibredb-clear-filters)) (should (equal "" passed)))) -;;; --------------------------- cj/force-nov-mode-for-epub --------------------- - -(ert-deftest test-calibredb-epub-force-nov-mode-on-epub-calls-nov-mode () - "Normal: a .epub buffer with nov-mode bound dispatches to `nov-mode' and -does not fall through to the original mode dispatcher." - (skip-unless (fboundp 'nov-mode)) - (let (orig-called nov-called) - (cl-letf (((symbol-function 'nov-mode) - (lambda () (setq nov-called t)))) - (with-temp-buffer - (setq buffer-file-name "/tmp/sample.epub") - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t))))) - (should nov-called) - (should-not orig-called))) - -(ert-deftest test-calibredb-epub-force-nov-mode-passes-through-non-epub () - "Boundary: a non-epub buffer falls through to the original mode dispatcher." - (let (orig-called) - (with-temp-buffer - (setq buffer-file-name "/tmp/sample.txt") - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t)))) - (should orig-called))) - -(ert-deftest test-calibredb-epub-force-nov-mode-passes-through-no-filename () - "Boundary: a buffer with no associated filename falls through to the -original mode dispatcher." - (let (orig-called) - (with-temp-buffer - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t)))) - (should orig-called))) - -(ert-deftest test-calibredb-epub-force-nov-mode-passes-through-when-nov-missing () - "Error: a .epub buffer falls through to the original dispatcher when nov-mode -is not defined (the require failed and there is nothing to dispatch to)." - (let ((saved (and (fboundp 'nov-mode) (symbol-function 'nov-mode))) - orig-called) - (when saved (fmakunbound 'nov-mode)) - (unwind-protect - (cl-letf (((symbol-function 'require) - ;; Pretend the (require 'nov nil t) call fails too. - (lambda (&rest _) nil))) - (with-temp-buffer - (setq buffer-file-name "/tmp/sample.epub") - (cj/force-nov-mode-for-epub - (lambda (&rest _) (setq orig-called t))))) - (when saved (fset 'nov-mode saved))) - (should orig-called))) - ;;; ---------------------------- cj/nov--metadata-get -------------------------- (ert-deftest test-calibredb-epub-metadata-get-symbol-key () diff --git a/tests/test-custom-buffer-file-move-buffer-and-file.el b/tests/test-custom-buffer-file-move-buffer-and-file.el index 8331db5c..b3d78ccf 100644 --- a/tests/test-custom-buffer-file-move-buffer-and-file.el +++ b/tests/test-custom-buffer-file-move-buffer-and-file.el @@ -884,11 +884,17 @@ (with-temp-file source-file (insert "new")) (find-file source-file) - ;; Mock yes-or-no-p to capture that it was called - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (prompt) + ;; The overwrite confirm goes through `cj/confirm-destructive', which + ;; reads a single key rather than a typed yes. Mock the key read, not + ;; `yes-or-no-p' -- mocking the latter would pass whether or not the + ;; prompt happened at all. + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (setq prompted t) - t)) + ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) + (error "overwrite confirm must not demand a typed yes"))) ((symbol-function 'read-directory-name) (lambda (&rest _) target-dir))) (call-interactively #'cj/move-buffer-and-file) @@ -907,11 +913,14 @@ (with-temp-file source-file (insert "new")) (find-file source-file) - ;; Mock yes-or-no-p to capture if it was called - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (prompt) - (setq prompted t) - t)) + ;; Both prompt paths are mocked, not just the old one. Watching + ;; `yes-or-no-p' alone would make this assertion unfalsifiable now + ;; that the confirm reads a key instead: it would pass whether the + ;; prompt was correctly skipped or merely moved. + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (setq prompted t) ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (setq prompted t) t)) ((symbol-function 'read-directory-name) (lambda (&rest _) target-dir))) (call-interactively #'cj/move-buffer-and-file) diff --git a/tests/test-custom-buffer-file-rename-buffer-and-file.el b/tests/test-custom-buffer-file-rename-buffer-and-file.el index 1eb61f1b..019fad8c 100644 --- a/tests/test-custom-buffer-file-rename-buffer-and-file.el +++ b/tests/test-custom-buffer-file-rename-buffer-and-file.el @@ -923,11 +923,17 @@ (with-temp-file new-file (insert "existing")) (find-file old-file) - ;; Mock yes-or-no-p to capture that it was called - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (prompt) + ;; The overwrite confirm goes through `cj/confirm-destructive', which + ;; reads a single key rather than a typed yes. Mock the key read, not + ;; `yes-or-no-p' -- mocking the latter would pass whether or not the + ;; prompt happened at all. + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (setq prompted t) - t)) + ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) + (error "overwrite confirm must not demand a typed yes"))) ((symbol-function 'read-string) (lambda (&rest _) "new.txt"))) (call-interactively #'cj/rename-buffer-and-file) diff --git a/tests/test-custom-comments-comment-padded-divider.el b/tests/test-custom-comments-comment-padded-divider.el index d4c18905..9f2b4fd7 100644 --- a/tests/test-custom-comments-comment-padded-divider.el +++ b/tests/test-custom-comments-comment-padded-divider.el @@ -246,5 +246,23 @@ Returns the buffer string for assertions." ;; Should include comment-end (should (string-match-p "\\*/" result)))) +;;; Rendered width honors LENGTH exactly + +(ert-deftest test-padded-divider-width-matches-length-exactly () + "Normal: each decoration line renders exactly LENGTH wide. +available-width forgot the doubled semicolon (elisp) and the space after +comment-start that the emit path adds, so dividers rendered LENGTH+2 +(elisp) or LENGTH+1 wide, contradicting the docstring." + ;; elisp: lone ";" doubles to ";;" plus a space + (let* ((result (test-padded-divider-at-column 0 ";" "" "-" "x" 40 1)) + (lines (split-string result "\n" t))) + (should (= 40 (length (car lines)))) + (should (= 40 (length (car (last lines)))))) + ;; c-style with an end delimiter and no doubling + (let* ((result (test-padded-divider-at-column 0 "/*" "*/" "-" "x" 40 1)) + (lines (split-string result "\n" t))) + (should (= 40 (length (car lines)))) + (should (= 40 (length (car (last lines))))))) + (provide 'test-custom-comments-comment-padded-divider) ;;; test-custom-comments-comment-padded-divider.el ends here diff --git a/tests/test-custom-comments-public-wrappers.el b/tests/test-custom-comments-public-wrappers.el index 42842649..2eda9d94 100644 --- a/tests/test-custom-comments-public-wrappers.el +++ b/tests/test-custom-comments-public-wrappers.el @@ -188,5 +188,30 @@ text via `read-from-minibuffer'." (cj/comment-block-banner) (should (string-match-p "Banner" (buffer-string))))) +;;; cj/--comment-read-syntax — the shared comment-syntax resolution + +(ert-deftest test-comment-read-syntax-uses-buffer-syntax () + "Normal: a buffer with comment syntax resolves without prompting." + (with-temp-buffer + (setq-local comment-start ";") + (setq-local comment-end "") + (cl-letf (((symbol-function 'read-string) + (lambda (&rest _) (error "should not prompt")))) + (should (equal (cj/--comment-read-syntax) '(";" . "")))))) + +(ert-deftest test-comment-read-syntax-nil-end-falls-back-to-empty () + "Boundary: a nil comment-end resolves to the empty string." + (with-temp-buffer + (setq-local comment-start "#") + (setq-local comment-end nil) + (should (equal (cj/--comment-read-syntax) '("#" . ""))))) + +(ert-deftest test-comment-read-syntax-prompts-when-unset () + "Error: no buffer comment-start falls back to the prompt." + (with-temp-buffer + (setq-local comment-start nil) + (cl-letf (((symbol-function 'read-string) (lambda (&rest _) "//"))) + (should (equal (car (cj/--comment-read-syntax)) "//"))))) + (provide 'test-custom-comments-public-wrappers) ;;; test-custom-comments-public-wrappers.el ends here diff --git a/tests/test-dashboard-config.el b/tests/test-dashboard-config.el index 2dbcd4f4..3a48ee56 100644 --- a/tests/test-dashboard-config.el +++ b/tests/test-dashboard-config.el @@ -56,5 +56,15 @@ start at the top. Without `set-window-start', batch redisplay leaves (when (buffer-live-p dash) (kill-buffer dash))))) +(ert-deftest test-dashboard-config-bookmark-override-deferred-to-package-load () + "Normal: the bookmarks override is defined exactly when dashboard-widgets is. +A bare top-level defun would exist even without the package (and be +clobbered when the package loads); the deferred registration means the +function tracks the package's own load state. Holds in both runners: +the hook env loads dashboard, the make-test env can't." + (if (featurep 'dashboard-widgets) + (should (fboundp 'dashboard-insert-bookmarks)) + (should-not (fboundp 'dashboard-insert-bookmarks)))) + (provide 'test-dashboard-config) ;;; test-dashboard-config.el ends here diff --git a/tests/test-dev-fkeys--f4-clean-rebuild-impl.el b/tests/test-dev-fkeys--f4-clean-rebuild-impl.el index 27c7c56a..bed51d79 100644 --- a/tests/test-dev-fkeys--f4-clean-rebuild-impl.el +++ b/tests/test-dev-fkeys--f4-clean-rebuild-impl.el @@ -3,7 +3,11 @@ ;;; Commentary: ;; Tests for the "Clean + Rebuild" action handler. Runs the heuristic clean ;; command via `compile' from the project root, then chains -;; `projectile-compile-project' on success via the one-shot finish hook. +;; `projectile-compile-project' on success via a one-shot finish hook +;; installed buffer-locally in the compilation buffer `compile' returns. +;; The global `compilation-finish-functions' is never touched, so a quit +;; before the compile starts or an unrelated concurrent compile can never +;; fire the chained rebuild. ;;; Code: @@ -24,6 +28,18 @@ Bind the dir path to ROOT in BODY. Cleans up on exit." ,@body) (delete-directory root t)))) +(defmacro test-dev-fkeys-cr--with-compilation-buffer (buf &rest body) + "Run BODY with BUF bound to a temp buffer standing in for a compilation buffer." + (declare (indent 1)) + `(let ((,buf (generate-new-buffer " *test-compilation*"))) + (unwind-protect + (progn ,@body) + (kill-buffer ,buf)))) + +(defun test-dev-fkeys-cr--local-hooks (buf) + "Return the buffer-local finish hooks of BUF, without the t marker." + (remq t (buffer-local-value 'compilation-finish-functions buf))) + ;;; Normal Cases (ert-deftest test-dev-fkeys-clean-rebuild-impl-runs-derived-clean-cmd () @@ -34,48 +50,50 @@ Components integrated: - `cj/--f4-clean-rebuild-impl' (unit under test) - `cj/--f4-derive-clean-cmd' (real) - `compile' (MOCKED — captures the command string) -- `projectile-compile-project' (MOCKED — no-op) -- `compilation-finish-functions' (real, scoped via let)" +- `projectile-compile-project' (MOCKED — no-op)" (test-dev-fkeys-cr--with-project '("Makefile") - (let ((compile-calls nil) - (compilation-finish-functions nil)) + (let ((compile-calls nil)) (cl-letf (((symbol-function 'compile) - (lambda (cmd) (push cmd compile-calls))) + (lambda (cmd) (push cmd compile-calls) nil)) ((symbol-function 'projectile-compile-project) (lambda (_arg) nil))) (cj/--f4-clean-rebuild-impl root) (should (equal compile-calls '("make clean"))))))) -(ert-deftest test-dev-fkeys-clean-rebuild-impl-installs-finish-hook () - "Normal: handler installs exactly one hook in `compilation-finish-functions'." +(ert-deftest test-dev-fkeys-clean-rebuild-impl-installs-hook-in-compilation-buffer () + "Normal: the one-shot hook lands buffer-locally in the buffer `compile' +returns; the global `compilation-finish-functions' stays untouched." (test-dev-fkeys-cr--with-project '("go.mod") - (let ((compilation-finish-functions nil)) - (cl-letf (((symbol-function 'compile) (lambda (_cmd) nil)) - ((symbol-function 'projectile-compile-project) - (lambda (_arg) nil))) - (cj/--f4-clean-rebuild-impl root) - (should (= (length compilation-finish-functions) 1)))))) + (test-dev-fkeys-cr--with-compilation-buffer buf + (let ((compilation-finish-functions nil)) + (cl-letf (((symbol-function 'compile) (lambda (_cmd) buf)) + ((symbol-function 'projectile-compile-project) + (lambda (_arg) nil))) + (cj/--f4-clean-rebuild-impl root) + (should (null compilation-finish-functions)) + (should (= 1 (length (test-dev-fkeys-cr--local-hooks buf))))))))) (ert-deftest test-dev-fkeys-clean-rebuild-impl-hook-runs-projectile-compile-on-success () - "Normal: when the clean step finishes successfully, the installed hook + "Normal: when the clean step finishes successfully, the buffer-local hook calls `projectile-compile-project' to do the rebuild." (test-dev-fkeys-cr--with-project '("Cargo.toml") - (let ((compile-calls 0) - (compilation-finish-functions nil)) - (cl-letf (((symbol-function 'compile) (lambda (_cmd) nil)) - ((symbol-function 'projectile-compile-project) - (lambda (_arg) (cl-incf compile-calls)))) - (cj/--f4-clean-rebuild-impl root) - (run-hook-with-args 'compilation-finish-functions nil "finished\n") - (should (= compile-calls 1)))))) + (test-dev-fkeys-cr--with-compilation-buffer buf + (let ((compile-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'compile) (lambda (_cmd) buf)) + ((symbol-function 'projectile-compile-project) + (lambda (_arg) (cl-incf compile-calls)))) + (cj/--f4-clean-rebuild-impl root) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions buf "finished\n")) + (should (= compile-calls 1))))))) (ert-deftest test-dev-fkeys-clean-rebuild-impl-runs-clean-from-project-root () "Normal: the clean compile runs with default-directory bound to ROOT." (test-dev-fkeys-cr--with-project '("Eask") - (let ((seen-dir nil) - (compilation-finish-functions nil)) + (let ((seen-dir nil)) (cl-letf (((symbol-function 'compile) - (lambda (_cmd) (setq seen-dir default-directory))) + (lambda (_cmd) (setq seen-dir default-directory) nil)) ((symbol-function 'projectile-compile-project) (lambda (_arg) nil))) (cj/--f4-clean-rebuild-impl root) @@ -87,14 +105,28 @@ calls `projectile-compile-project' to do the rebuild." (ert-deftest test-dev-fkeys-clean-rebuild-impl-hook-skips-rebuild-on-failure () "Boundary: when the clean step fails, projectile-compile-project does not run." (test-dev-fkeys-cr--with-project '("Makefile") - (let ((compile-calls 0) - (compilation-finish-functions nil)) + (test-dev-fkeys-cr--with-compilation-buffer buf + (let ((compile-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'compile) (lambda (_cmd) buf)) + ((symbol-function 'projectile-compile-project) + (lambda (_arg) (cl-incf compile-calls)))) + (cj/--f4-clean-rebuild-impl root) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions + buf "exited abnormally\n")) + (should (= compile-calls 0))))))) + +(ert-deftest test-dev-fkeys-clean-rebuild-impl-dead-compile-buffer-no-global-hook () + "Boundary: when `compile' returns no live buffer, nothing is installed +anywhere — the global hook list stays empty." + (test-dev-fkeys-cr--with-project '("Makefile") + (let ((compilation-finish-functions nil)) (cl-letf (((symbol-function 'compile) (lambda (_cmd) nil)) ((symbol-function 'projectile-compile-project) - (lambda (_arg) (cl-incf compile-calls)))) + (lambda (_arg) nil))) (cj/--f4-clean-rebuild-impl root) - (run-hook-with-args 'compilation-finish-functions nil "exited abnormally\n") - (should (= compile-calls 0)))))) + (should (null compilation-finish-functions)))))) ;;; Error Cases diff --git a/tests/test-dev-fkeys--f4-compile-and-run-impl.el b/tests/test-dev-fkeys--f4-compile-and-run-impl.el index d59a6cd6..34e5bdf3 100644 --- a/tests/test-dev-fkeys--f4-compile-and-run-impl.el +++ b/tests/test-dev-fkeys--f4-compile-and-run-impl.el @@ -2,8 +2,11 @@ ;;; Commentary: ;; Tests for the "Compile + Run" action handler. After kicking off the -;; compile, attaches a one-shot `compilation-finish-functions' hook that -;; runs the project on success. +;; compile, attaches a one-shot finish hook buffer-locally in the +;; compilation buffer projectile returns, so the global +;; `compilation-finish-functions' is never touched. A quit at +;; projectile's compile prompt therefore can never leave an armed hook +;; that a later unrelated compile would fire. ;;; Code: @@ -12,6 +15,14 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'dev-fkeys) +(defmacro test-dev-fkeys-car--with-buffer (buf &rest body) + "Run BODY with BUF bound to a temp buffer standing in for a compilation buffer." + (declare (indent 1)) + `(let ((,buf (generate-new-buffer " *test-compilation*"))) + (unwind-protect + (progn ,@body) + (kill-buffer ,buf)))) + ;;; Normal Cases (ert-deftest test-dev-fkeys-compile-and-run-impl-invokes-projectile-compile () @@ -19,57 +30,77 @@ Components integrated: - `cj/--f4-compile-and-run-impl' (unit under test) -- `projectile-compile-project' (MOCKED via cl-letf) -- `compilation-finish-functions' (real, scoped via let)" - (let ((compile-calls 0) - (compilation-finish-functions nil)) +- `projectile-compile-project' (MOCKED via cl-letf)" + (let ((compile-calls 0)) (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) (cl-incf compile-calls)))) + (lambda (_arg) (cl-incf compile-calls) nil))) (cj/--f4-compile-and-run-impl) (should (= compile-calls 1))))) -(ert-deftest test-dev-fkeys-compile-and-run-impl-installs-finish-hook () - "Normal: handler installs exactly one hook in `compilation-finish-functions'." - (let ((compilation-finish-functions nil)) - (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) nil))) - (cj/--f4-compile-and-run-impl) - (should (= (length compilation-finish-functions) 1))))) +(ert-deftest test-dev-fkeys-compile-and-run-impl-installs-hook-in-compilation-buffer () + "Normal: the one-shot hook lands buffer-locally in the compilation buffer; +the global `compilation-finish-functions' stays untouched." + (test-dev-fkeys-car--with-buffer buf + (let ((compilation-finish-functions nil)) + (cl-letf (((symbol-function 'projectile-compile-project) + (lambda (_arg) buf))) + (cj/--f4-compile-and-run-impl) + (should (null compilation-finish-functions)) + (should (= 1 (length (remq t (buffer-local-value + 'compilation-finish-functions buf))))))))) (ert-deftest test-dev-fkeys-compile-and-run-impl-hook-runs-projectile-run-on-success () - "Normal: when the compile finishes successfully, the installed hook calls -`projectile-run-project'. + "Normal: when the compile finishes successfully, the buffer-local hook +calls `projectile-run-project'. Components integrated: - `cj/--f4-compile-and-run-impl' (unit under test) -- `projectile-compile-project' (MOCKED — no-op) +- `projectile-compile-project' (MOCKED — returns the compilation buffer) - `projectile-run-project' (MOCKED — counts calls) -- `compilation-finish-functions' (real) +- `compilation-finish-functions' (real, buffer-local) - `run-hook-with-args' (real — simulates compile.el firing the hook)" - (let ((run-calls 0) - (compilation-finish-functions nil)) - (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) nil)) - ((symbol-function 'projectile-run-project) - (lambda (_arg) (cl-incf run-calls)))) - (cj/--f4-compile-and-run-impl) - (run-hook-with-args 'compilation-finish-functions nil "finished\n") - (should (= run-calls 1))))) + (test-dev-fkeys-car--with-buffer buf + (let ((run-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'projectile-compile-project) + (lambda (_arg) buf)) + ((symbol-function 'projectile-run-project) + (lambda (_arg) (cl-incf run-calls)))) + (cj/--f4-compile-and-run-impl) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions buf "finished\n")) + (should (= run-calls 1)))))) ;;; Boundary Cases (ert-deftest test-dev-fkeys-compile-and-run-impl-hook-skips-projectile-run-on-failure () "Boundary: when the compile fails, projectile-run-project must not run. The hook still self-removes (covered in the make-once-hook tests)." - (let ((run-calls 0) - (compilation-finish-functions nil)) + (test-dev-fkeys-car--with-buffer buf + (let ((run-calls 0) + (compilation-finish-functions nil)) + (cl-letf (((symbol-function 'projectile-compile-project) + (lambda (_arg) buf)) + ((symbol-function 'projectile-run-project) + (lambda (_arg) (cl-incf run-calls)))) + (cj/--f4-compile-and-run-impl) + (with-current-buffer buf + (run-hook-with-args 'compilation-finish-functions + buf "exited abnormally\n")) + (should (= run-calls 0)))))) + +(ert-deftest test-dev-fkeys-compile-and-run-impl-quit-leaves-no-global-hook () + "Boundary: a quit at projectile's prompt leaves no armed hook anywhere. +This is the regression the buffer-local install exists to prevent: the +old shape armed a global hook before the prompt, so C-g left it live and +the next unrelated compile fired the chained run." + (let ((compilation-finish-functions nil)) (cl-letf (((symbol-function 'projectile-compile-project) - (lambda (_arg) nil)) - ((symbol-function 'projectile-run-project) - (lambda (_arg) (cl-incf run-calls)))) - (cj/--f4-compile-and-run-impl) - (run-hook-with-args 'compilation-finish-functions nil "exited abnormally\n") - (should (= run-calls 0))))) + (lambda (_arg) (signal 'quit nil)))) + (condition-case nil + (cj/--f4-compile-and-run-impl) + (quit nil)) + (should (null compilation-finish-functions))))) (provide 'test-dev-fkeys--f4-compile-and-run-impl) ;;; test-dev-fkeys--f4-compile-and-run-impl.el ends here diff --git a/tests/test-dev-fkeys--f4-make-once-hook.el b/tests/test-dev-fkeys--f4-make-once-hook.el index b6c71dd7..4fc84e63 100644 --- a/tests/test-dev-fkeys--f4-make-once-hook.el +++ b/tests/test-dev-fkeys--f4-make-once-hook.el @@ -95,6 +95,21 @@ hook exactly once per compile, so the practical contract is one-shot." (funcall hook nil "interrupt\n")) (should (= called 0)))) +(ert-deftest test-dev-fkeys-make-once-hook-removes-itself-buffer-locally () + "Boundary: a hook installed buffer-locally removes its local entry when +run in that buffer — the shape used by the F4 chained-compile handlers." + (let ((buf (generate-new-buffer " *test-once-hook*")) + (called 0)) + (unwind-protect + (let ((hook (cj/--f4-make-once-hook (lambda () (cl-incf called))))) + (with-current-buffer buf + (add-hook 'compilation-finish-functions hook nil t) + (funcall hook buf "finished\n") + (should-not (memq hook (buffer-local-value + 'compilation-finish-functions buf)))) + (should (= called 1))) + (kill-buffer buf)))) + ;;; Error Cases (ert-deftest test-dev-fkeys-make-once-hook-then-fn-error-still-removes-hook () diff --git a/tests/test-dev-fkeys--f6-test-runner-cmd-for.el b/tests/test-dev-fkeys--f6-test-runner-cmd-for.el index d7b6a059..59d0ba42 100644 --- a/tests/test-dev-fkeys--f6-test-runner-cmd-for.el +++ b/tests/test-dev-fkeys--f6-test-runner-cmd-for.el @@ -138,10 +138,15 @@ rather than a silent nil that F6's outer wrapper interprets as 'typescript t "src/foo.test.ts" "foo" "src") "npx --no-install vitest src/foo.test.ts")))) -(ert-deftest test-dev-fkeys-f6-cmd-for-javascript-returns-nil () - "Error: JavaScript is punted for v1 and returns nil." - (should (null (cj/--f6-test-runner-cmd-for - 'javascript t "src/foo.test.js" "foo" "src")))) +(ert-deftest test-dev-fkeys-f6-cmd-for-javascript-uses-npx-runner () + "Normal: javascript gets the same npx runner command as typescript. +The language detector classifies js/jsx and the test-file detector +recognizes JS test files, but the dispatch had no javascript arm, so +C-F6 on a JS test errored even though the npx path would run it." + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil))) + (should (equal (cj/--f6-test-runner-cmd-for + 'javascript t "src/foo.test.js" "foo" "src") + "npx --no-install jest src/foo.test.js")))) (ert-deftest test-dev-fkeys-f6-cmd-for-unknown-returns-nil () "Error: an unknown language returns nil." diff --git a/tests/test-diff-config--ediff-options.el b/tests/test-diff-config--ediff-options.el new file mode 100644 index 00000000..a43637d9 --- /dev/null +++ b/tests/test-diff-config--ediff-options.el @@ -0,0 +1,27 @@ +;;; test-diff-config--ediff-options.el --- Tests for ediff diff options -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins the removal of the global "-w" default for `ediff-diff-options'. +;; With "-w", every ediff session ignores ALL whitespace, so +;; indentation-only changes (significant in Python, Makefiles, YAML) +;; compare as identical. Whitespace-ignoring is a per-session toggle +;; (ediff's `##'), not a global default. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'diff-config) + +;;; Normal Cases + +(ert-deftest test-diff-config-ediff-options-no-global-whitespace-ignore () + "Normal: after ediff loads, no global -w sits in ediff-diff-options. +The use-package :custom values apply when the deferred package loads, +so the assertion must run with ediff actually loaded." + (require 'ediff) + (should (not (string-match-p "-w" (or ediff-diff-options ""))))) + +(provide 'test-diff-config--ediff-options) +;;; test-diff-config--ediff-options.el ends here diff --git a/tests/test-dirvish-config-runtime-requires.el b/tests/test-dirvish-config-runtime-requires.el index 34fb67ac..ca94e4b5 100644 --- a/tests/test-dirvish-config-runtime-requires.el +++ b/tests/test-dirvish-config-runtime-requires.el @@ -3,15 +3,13 @@ ;;; Commentary: ;; dirvish-config.el builds `dirvish-quick-access-entries' from `code-dir', ;; `music-dir', `pix-dir' (and friends) at load time and binds keys to -;; `cj/xdg-open' / `cj/open-file-with-command', so it depends on user-constants -;; and system-utils at runtime. Those were declared with `eval-when-compile', -;; which leaves the compiled module without the requires at load — fragile -;; under init order. This is a dependency-contract smoke test: requiring -;; dirvish-config in isolation must pull both features in, so it fails if the -;; requires are dropped entirely. (It can't catch a downgrade back to -;; `eval-when-compile', since that form still runs when the file loads as -;; source, which the test harness does — that regression is guarded by keeping -;; the plain requires in review, not by this test.) +;; `cj/xdg-open' (external-open) and `cj/open-file-with-command' +;; (system-utils), so it depends on user-constants, system-utils, and +;; external-open at runtime. This is a dependency-contract smoke test: +;; requiring dirvish-config in isolation must pull those features in, so it +;; fails if the requires are dropped entirely. Run it with `make test-file' +;; for a clean signal: in the full suite another file may already have loaded +;; external-open, masking a regression here. ;;; Code: @@ -26,5 +24,13 @@ "Normal: requiring dirvish-config pulls in system-utils at runtime." (should (featurep 'system-utils))) +(ert-deftest test-dirvish-config-loads-external-open () + "Normal: requiring dirvish-config pulls in external-open at runtime. +The keys `o' and the OS-handler fallback call `cj/xdg-open', which lives +in external-open; without the require the binding works only when init +order happens to load external-open first." + (should (featurep 'external-open)) + (should (fboundp 'cj/xdg-open))) + (provide 'test-dirvish-config-runtime-requires) ;;; test-dirvish-config-runtime-requires.el ends here diff --git a/tests/test-dwim-shell-config-runtime-requires.el b/tests/test-dwim-shell-config-runtime-requires.el new file mode 100644 index 00000000..ab53e7d4 --- /dev/null +++ b/tests/test-dwim-shell-config-runtime-requires.el @@ -0,0 +1,24 @@ +;;; test-dwim-shell-config-runtime-requires.el --- dwim-shell-config declares its deps -*- lexical-binding: t; -*- + +;;; Commentary: +;; dwim-shell-config.el calls `cj/xdg-open' (external-open) to open a +;; conversion's output file, but declared it only with `declare-function' +;; and never required external-open. The binding works at runtime only +;; because init.el happens to load external-open first — fragile under init +;; order, and the "Direct test load: yes" header claims otherwise. This is +;; a dependency-contract smoke test: requiring dwim-shell-config in isolation +;; must pull external-open in. Run with `make test-file' for a clean signal; +;; in the full suite another file may already have loaded external-open. + +;;; Code: + +(require 'ert) +(require 'dwim-shell-config) + +(ert-deftest test-dwim-shell-config-loads-external-open () + "Normal: requiring dwim-shell-config pulls in external-open at runtime." + (should (featurep 'external-open)) + (should (fboundp 'cj/xdg-open))) + +(provide 'test-dwim-shell-config-runtime-requires) +;;; test-dwim-shell-config-runtime-requires.el ends here diff --git a/tests/test-elfeed-config-helpers.el b/tests/test-elfeed-config-helpers.el index 16cbb744..95a98e83 100644 --- a/tests/test-elfeed-config-helpers.el +++ b/tests/test-elfeed-config-helpers.el @@ -1,10 +1,7 @@ ;;; test-elfeed-config-helpers.el --- Tests for elfeed stream/process helpers -*- lexical-binding: t; -*- ;;; Commentary: -;; Coverage for two elfeed-config helpers that were untested: -;; - cj/extract-stream-url: runs yt-dlp -g to resolve a direct stream URL, -;; returning the URL, nil on non-URL / nonzero exit, or signalling when -;; yt-dlp is absent. +;; Coverage for the elfeed-config entry-processing helper: ;; - cj/elfeed-process-entries: applies an action to each selected entry, ;; marking them read; errors when nothing is selected, skips entries with ;; no link, and (by default) catches per-entry action errors. @@ -34,40 +31,6 @@ (require 'elfeed-config) (require 'elfeed nil t) -;;; cj/extract-stream-url - -(ert-deftest test-elfeed-extract-stream-url-normal-returns-url () - "Normal: a successful yt-dlp run returns the trimmed https stream URL." - (cl-letf (((symbol-function 'executable-find) - (lambda (p &rest _) (and (equal p "yt-dlp") "/usr/bin/yt-dlp"))) - ((symbol-function 'cj/log-silently) #'ignore) - ((symbol-function 'call-process) - (lambda (_prog _infile _dest _disp &rest _args) - (insert "https://stream.example/abc\n") 0))) - (should (equal "https://stream.example/abc" - (cj/extract-stream-url "https://youtube.com/watch?v=x" "best"))))) - -(ert-deftest test-elfeed-extract-stream-url-boundary-non-url-output-is-nil () - "Boundary: output that is not an http(s) URL yields nil, not the raw text." - (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/yt-dlp")) - ((symbol-function 'cj/log-silently) #'ignore) - ((symbol-function 'call-process) - (lambda (_p _i _d _disp &rest _) (insert "ERROR: unavailable\n") 0))) - (should (null (cj/extract-stream-url "u" nil))))) - -(ert-deftest test-elfeed-extract-stream-url-boundary-nonzero-exit-is-nil () - "Boundary: a nonzero yt-dlp exit code yields nil." - (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/yt-dlp")) - ((symbol-function 'cj/log-silently) #'ignore) - ((symbol-function 'call-process) - (lambda (_p _i _d _disp &rest _) (insert "boom") 1))) - (should (null (cj/extract-stream-url "u" nil))))) - -(ert-deftest test-elfeed-extract-stream-url-error-without-yt-dlp () - "Error: a missing yt-dlp signals before attempting the call." - (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) - (should-error (cj/extract-stream-url "u" "best") :type 'error))) - ;;; cj/elfeed-process-entries (defun cj/test--elfeed-entry (link) diff --git a/tests/test-external-open--open-with-argv.el b/tests/test-external-open--open-with-argv.el new file mode 100644 index 00000000..27a7e811 --- /dev/null +++ b/tests/test-external-open--open-with-argv.el @@ -0,0 +1,59 @@ +;;; test-external-open--open-with-argv.el --- Tests for cj/--open-with-argv -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for cj/--open-with-argv, the pure builder that turns the +;; user-typed "open with" command plus a file path into an argv list. +;; The argv shape is the hardening: the file is one list element, so paths +;; with spaces or shell metacharacters never meet a shell. +;; +;; Test organization: +;; - Normal Cases: bare program, program with args, quoted argument +;; - Boundary Cases: file with spaces and metacharacters stays one element +;; - Error Cases: empty and whitespace-only commands +;; +;;; Code: + +(require 'ert) +(require 'external-open) + +;;; Normal Cases + +(ert-deftest test-external-open--open-with-argv-normal-bare-program () + "Normal: a bare program name yields (PROGRAM FILE)." + (should (equal (cj/--open-with-argv "vlc" "/tmp/foo.mp4") + '("vlc" "/tmp/foo.mp4")))) + +(ert-deftest test-external-open--open-with-argv-normal-program-with-args () + "Normal: a command typed with arguments splits into argv words." + (should (equal (cj/--open-with-argv "mpv --fs --loop" "/tmp/foo.mp4") + '("mpv" "--fs" "--loop" "/tmp/foo.mp4")))) + +(ert-deftest test-external-open--open-with-argv-normal-quoted-arg-survives () + "Normal: a double-quoted argument stays one word." + (should (equal (cj/--open-with-argv "player \"two words\"" "/tmp/foo.mp4") + '("player" "two words" "/tmp/foo.mp4")))) + +;;; Boundary Cases + +(ert-deftest test-external-open--open-with-argv-boundary-file-with-spaces () + "Boundary: a path with spaces is one argv element, untouched." + (let ((file "/tmp/my file (draft).mp4")) + (should (equal (car (last (cj/--open-with-argv "vlc" file))) file)))) + +(ert-deftest test-external-open--open-with-argv-boundary-file-with-metacharacters () + "Boundary: shell metacharacters in the path arrive verbatim." + (let ((file "/tmp/a;b&c$(d)'e.mp4")) + (should (equal (car (last (cj/--open-with-argv "vlc" file))) file)))) + +;;; Error Cases + +(ert-deftest test-external-open--open-with-argv-error-empty-command () + "Error: an empty command signals user-error." + (should-error (cj/--open-with-argv "" "/tmp/foo.mp4") :type 'user-error)) + +(ert-deftest test-external-open--open-with-argv-error-whitespace-command () + "Error: a whitespace-only command signals user-error." + (should-error (cj/--open-with-argv " " "/tmp/foo.mp4") :type 'user-error)) + +(provide 'test-external-open--open-with-argv) +;;; test-external-open--open-with-argv.el ends here diff --git a/tests/test-external-open-commands.el b/tests/test-external-open-commands.el index 3d8adc15..5cab1196 100644 --- a/tests/test-external-open-commands.el +++ b/tests/test-external-open-commands.el @@ -64,22 +64,41 @@ (should-error (cj/open-this-file-with "vlc") :type 'user-error))) (ert-deftest test-external-open-open-this-file-with-spawns-detached-process () - "Normal: posix path invokes `call-process-shell-command' with nohup + bg." - (let ((cmd nil)) + "Normal: posix path launches an argv `call-process' with DESTINATION 0." + (let ((captured nil)) (with-temp-buffer - (setq buffer-file-name "/tmp/foo.mp4") + (setq buffer-file-name "/tmp/my file.mp4") (cl-letf (((symbol-function 'env-windows-p) (lambda () nil)) - ((symbol-function 'call-process-shell-command) - (lambda (c _infile _buf &rest _) - (setq cmd c)))) - (cj/open-this-file-with "vlc")) + ((symbol-function 'executable-find) + (lambda (&rest _) "/usr/bin/vlc")) + ((symbol-function 'call-process) + (lambda (&rest args) (setq captured args) 0))) + (cj/open-this-file-with "vlc --fs")) (setq buffer-file-name nil)) - (should (string-match-p "^nohup vlc " cmd)) - (should (string-match-p "&$" cmd)) - (should (string-match-p ">/dev/null" cmd)))) + (should (equal captured '("vlc" nil 0 nil "--fs" "/tmp/my file.mp4"))))) + +(ert-deftest test-external-open-open-this-file-with-errors-missing-program () + "Error: a program not on PATH signals user-error before launching." + (with-temp-buffer + (setq buffer-file-name "/tmp/foo.mp4") + (cl-letf (((symbol-function 'env-windows-p) (lambda () nil)) + ((symbol-function 'executable-find) (lambda (&rest _) nil))) + (should-error (cj/open-this-file-with "no-such-program") + :type 'user-error)) + (setq buffer-file-name nil))) ;;; cj/find-file-auto +(ert-deftest test-external-open-video-looping-errors-missing-program () + "Error: a missing video player gives a clear user-error, not an opaque crash. +The command fires via the find-file advice, so visiting a video on a +machine without mpv must fail with a message naming the program." + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'call-process) + (lambda (&rest _) (error "call-process should not run")))) + (should-error (cj/open-video-looping "/tmp/some-video.mp4") + :type 'user-error))) + (ert-deftest test-external-open-find-file-auto-routes-media-externally () "Normal: a non-video external extension (`.docx', in `default-open-extensions') triggers `cj/xdg-open' instead of the original diff --git a/tests/test-flyspell-and-abbrev.el b/tests/test-flyspell-and-abbrev.el index 3b494d5e..b4be6ab3 100644 --- a/tests/test-flyspell-and-abbrev.el +++ b/tests/test-flyspell-and-abbrev.el @@ -17,6 +17,7 @@ (require 'ert) (require 'cl-lib) +(require 'user-constants) ;; org-dir, read by the ispell :config below (require 'flyspell) (require 'flyspell-and-abbrev) @@ -27,6 +28,23 @@ (overlay-put o 'face 'flyspell-incorrect) o)) +;; ------------------------- org src-block skip entry --------------------------- + +(ert-deftest test-flyspell-ispell-skip-entry-matches-src-block-lines () + "Normal: the ispell skip entry matches real org src-block delimiters. +The old entry used \"#+\" (one-or-more #), which matches no real +begin_src line, so ispell spell-checked inside every org code block." + (require 'ispell) + (let ((entry (seq-find (lambda (e) + (and (consp e) (stringp (car e)) + (string-match-p "BEGIN_SRC" (car e)))) + ispell-skip-region-alist))) + (should entry) + (let ((case-fold-search t)) + (should (string-match-p (car entry) "#+BEGIN_SRC emacs-lisp")) + (should (string-match-p (car entry) "#+begin_src python")) + (should (string-match-p (cdr entry) "#+end_src"))))) + ;; ------------------------ cj/--require-spell-checker ------------------------- (ert-deftest test-flyspell-require-spell-checker-present () diff --git a/tests/test-font-config--frame-lifecycle.el b/tests/test-font-config--frame-lifecycle.el deleted file mode 100644 index 8f338b99..00000000 --- a/tests/test-font-config--frame-lifecycle.el +++ /dev/null @@ -1,75 +0,0 @@ -;;; test-font-config--frame-lifecycle.el --- Tests for the lifted font frame helpers -*- lexical-binding: t; -*- - -;;; Commentary: -;; cj/apply-font-settings-to-frame, cj/cleanup-frame-list, and -;; cj/maybe-install-nerd-icons-fonts were defined inside use-package -;; :config / with-eval-after-load (unreachable under `make test'). Lifting -;; them to top level makes their branching unit-testable; env-gui-p and the -;; package side-effect calls are mocked at the boundary. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'font-config) - -(defvar cj/fontaine-configured-frames) - -(ert-deftest test-font-cleanup-frame-list-removes-frame () - "Normal: cleanup drops the given frame from the configured list." - (let ((cj/fontaine-configured-frames '(fr1 fr2 fr3))) - (cj/cleanup-frame-list 'fr2) - (should (equal cj/fontaine-configured-frames '(fr1 fr3))))) - -(ert-deftest test-font-apply-gui-unconfigured-sets-preset () - "Normal: a GUI frame not yet configured gets the preset and is tracked." - (let ((cj/fontaine-configured-frames nil) - (called nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) - (cj/apply-font-settings-to-frame (selected-frame))) - (should called) - (should (member (selected-frame) cj/fontaine-configured-frames)))) - -(ert-deftest test-font-apply-already-configured-is-noop () - "Boundary: an already-configured frame is not re-preset." - (let ((cj/fontaine-configured-frames (list (selected-frame))) - (called nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) - (cj/apply-font-settings-to-frame (selected-frame))) - (should-not called))) - -(ert-deftest test-font-apply-non-gui-is-noop () - "Boundary: without a GUI nothing is applied or tracked." - (let ((cj/fontaine-configured-frames nil) - (called nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () nil)) - ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) - (cj/apply-font-settings-to-frame (selected-frame))) - (should-not called) - (should-not (member (selected-frame) cj/fontaine-configured-frames)))) - -(ert-deftest test-font-maybe-install-icons-gui-missing-installs () - "Normal: GUI present and font missing triggers the install." - (let ((installed nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'cj/font-installed-p) (lambda (_n) nil)) - ((symbol-function 'nerd-icons-install-fonts) (lambda (&rest _) (setq installed t))) - ((symbol-function 'remove-hook) #'ignore)) - (cj/maybe-install-nerd-icons-fonts)) - (should installed))) - -(ert-deftest test-font-maybe-install-icons-already-present-skips () - "Boundary: an installed font means no install attempt." - (let ((installed nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'cj/font-installed-p) (lambda (_n) t)) - ((symbol-function 'nerd-icons-install-fonts) (lambda (&rest _) (setq installed t)))) - (cj/maybe-install-nerd-icons-fonts)) - (should-not installed))) - -(provide 'test-font-config--frame-lifecycle) -;;; test-font-config--frame-lifecycle.el ends here diff --git a/tests/test-font-config.el b/tests/test-font-config.el index 4df2b41a..06ea226b 100644 --- a/tests/test-font-config.el +++ b/tests/test-font-config.el @@ -4,11 +4,10 @@ ;; font-config.el is mostly top-level font/package setup. These smoke tests ;; cover the logic that should stay correct regardless of which fonts are -;; installed: the install check, and the daemon-frame font applier (env-gui-p -;; guard plus idempotency). The module :demand's fontaine and references -;; nerd-icons, so the tests skip when those packages are absent rather than -;; failing on a bare checkout. GUI and font lookups are stubbed so the run -;; stays headless. +;; installed: the install check, task-oriented Fontaine picker, persistence, +;; and emoji setup. The module :demand's fontaine and references nerd-icons, so +;; the tests skip when those packages are absent rather than failing on a bare +;; checkout. GUI and font lookups are stubbed so the run stays headless. ;;; Code: @@ -41,34 +40,32 @@ (cl-letf (((symbol-function 'find-font) (lambda (&rest _) nil))) (should (null (cj/font-installed-p "No Such Font 12345"))))) -;;; cj/apply-font-settings-to-frame +;;; cj/maybe-install-nerd-icons-fonts -(ert-deftest test-font-config-apply-font-settings-noop-without-gui () - "Boundary: on a non-GUI frame the applier does nothing and does not error." +(ert-deftest test-font-config-nerd-icons-missing-font-installs-on-gui () + "Normal: a missing Nerd Icons font is installed on a GUI frame." (skip-unless test-font-config--available) (require 'font-config) - (let ((cj/fontaine-configured-frames nil) - (applied nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) nil)) - ((symbol-function 'fontaine-set-preset) - (lambda (&rest _) (setq applied t)))) - (cj/apply-font-settings-to-frame (selected-frame)) - (should-not applied) - (should-not cj/fontaine-configured-frames)))) - -(ert-deftest test-font-config-apply-font-settings-applies-once-per-frame () - "Normal: on a GUI frame the applier sets the preset once and is idempotent." - (skip-unless test-font-config--available) - (require 'font-config) - (let ((cj/fontaine-configured-frames nil) - (calls 0)) - (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) t)) - ((symbol-function 'fontaine-set-preset) - (lambda (&rest _) (setq calls (1+ calls))))) - (cj/apply-font-settings-to-frame (selected-frame)) - (cj/apply-font-settings-to-frame (selected-frame)) - (should (= calls 1)) - (should (memq (selected-frame) cj/fontaine-configured-frames))))) + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_name) nil)) + ((symbol-function 'nerd-icons-install-fonts) + (lambda (&rest _) (setq installed t))) + ((symbol-function 'remove-hook) #'ignore)) + (cj/maybe-install-nerd-icons-fonts)) + (should installed))) + +(ert-deftest test-font-config-nerd-icons-installed-font-skips-install () + "Boundary: an installed Nerd Icons font needs no install attempt." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_name) t)) + ((symbol-function 'nerd-icons-install-fonts) + (lambda (&rest _) (setq installed t)))) + (cj/maybe-install-nerd-icons-fonts)) + (should-not installed))) ;;; cj/setup-emoji-fontset @@ -135,5 +132,206 @@ (when (get-buffer "*Available Fonts*") (kill-buffer "*Available Fonts*"))))) +;;; Fontaine workflow profiles + +(ert-deftest test-font-config-fontaine-presets-are-task-oriented () + "Normal: the picker exposes eight complete workflow destinations." + (skip-unless test-font-config--available) + (require 'font-config) + (should (equal (delq t (mapcar #'car fontaine-presets)) + '(everyday writing reading coding-xs coding-m coding-l coding-xl + presentation)))) + +(ert-deftest test-font-config-fontaine-candidates-describe-end-state () + "Normal: every profile label names its purpose, fonts, and point size." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((candidates (cj/fontaine-profile-candidates))) + (should (= (length candidates) 8)) + (should (member (nth 0 candidates) + '("Everyday — Berkeley Mono + Lexend · 13 pt" + "Everyday — Berkeley Mono + Lexend · 14 pt"))) + (should (equal (nth 1 candidates) + "Writing — Berkeley Mono + Merriweather · 14 pt")) + (should (equal (nth 2 candidates) + "Reading — Merriweather · 14 pt")) + (should (equal (nth 3 candidates) + "Coding XS — Berkeley Mono · 11 pt")) + (should (equal (nth 4 candidates) + "Coding M — Berkeley Mono · 13 pt")) + (should (equal (nth 5 candidates) + "Coding L — Berkeley Mono · 14 pt")) + (should (equal (nth 6 candidates) + "Coding XL — Berkeley Mono · 16 pt")) + (should (equal (nth 7 candidates) + "Presentation — Berkeley Mono + Lexend · 20 pt")))) + +(ert-deftest test-font-config-fontaine-candidate-round-trips-to-profile () + "Boundary: a displayed destination maps back to its Fontaine symbol." + (skip-unless test-font-config--available) + (require 'font-config) + (dolist (profile '(everyday writing reading coding-xs coding-m coding-l coding-xl + presentation)) + (let ((label (cj/fontaine-profile-label profile))) + (should (eq (cj/fontaine-profile-from-label label) profile))))) + +(ert-deftest test-font-config-fontaine-uses-one-monospace-family () + "Normal: every workflow profile uses Berkeley Mono for fixed pitch." + (skip-unless test-font-config--available) + (require 'font-config) + (dolist (profile '(everyday writing coding-xs coding-m coding-l coding-xl presentation)) + (let ((properties (fontaine--get-preset-properties profile))) + (should (equal (plist-get properties :default-family) + "BerkeleyMono Nerd Font"))))) + +(ert-deftest test-font-config-fontaine-reading-is-merriweather-only () + "Normal: Reading uses Merriweather for every primary face family." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((properties (fontaine--get-preset-properties 'reading))) + (dolist (property '(:default-family + :fixed-pitch-family + :fixed-pitch-serif-family + :variable-pitch-family)) + (should (equal (plist-get properties property) "Merriweather"))))) + +(ert-deftest test-font-config-fontaine-reading-properties-are-public () + "Normal: consumers can resolve Reading without Fontaine private functions." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((properties (cj/fontaine-profile-properties 'reading))) + (should (equal (plist-get properties :default-family) "Merriweather")) + (should (= (plist-get properties :default-height) 140)))) + +(ert-deftest test-font-config-fontaine-remaps-reading-buffer-locally () + "Normal: the local adapter applies all Reading families at an override height." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((calls nil)) + (cl-letf (((symbol-function 'face-remap-add-relative) + (lambda (face &rest properties) + (push (cons face properties) calls) + face))) + (should (equal (cj/fontaine-remap-buffer-to-profile 'reading 180) + '(default fixed-pitch fixed-pitch-serif variable-pitch)))) + (dolist (face '(default fixed-pitch fixed-pitch-serif variable-pitch)) + (should (member (list face :family "Merriweather" :height 180) + calls))))) + +(ert-deftest test-font-config-fontaine-ui-buffer-remaps-default-to-berkeley () + "Normal: minibuffer and echo buffers remap their default face to Berkeley." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((base nil)) + (cl-letf (((symbol-function 'face-remap-set-base) + (lambda (face &rest specs) (setq base (cons face specs))))) + (cj/fontaine-remap-ui-buffer)) + (should (equal base + '(default (:family "BerkeleyMono Nerd Font")))))) + +(ert-deftest test-font-config-fontaine-ui-chrome-stays-berkeley () + "Normal: Fontaine reasserts Berkeley on chrome faces and echo buffers." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((faces nil) + (remap-count 0)) + (cl-letf (((symbol-function 'facep) (lambda (_face) t)) + ((symbol-function 'set-face-attribute) + (lambda (face _frame &rest properties) + (push (cons face properties) faces))) + ((symbol-function 'get-buffer) (lambda (_name) (current-buffer))) + ((symbol-function 'cj/fontaine-remap-ui-buffer) + (lambda () (setq remap-count (1+ remap-count))))) + (cj/fontaine-keep-ui-chrome-monospace)) + (dolist (face '(mode-line mode-line-active mode-line-inactive + minibuffer-prompt)) + (should (member (list face :family "BerkeleyMono Nerd Font") faces))) + (should (= remap-count 2)))) + +(ert-deftest test-font-config-fontaine-ui-chrome-hooks-are-installed () + "Boundary: profile, theme, and minibuffer changes restore UI typography." + (skip-unless test-font-config--available) + (require 'font-config) + (should (memq 'cj/fontaine-keep-ui-chrome-monospace + fontaine-set-preset-hook)) + (should (memq 'cj/fontaine-keep-ui-chrome-monospace + enable-theme-functions)) + (should (memq 'cj/fontaine-remap-ui-buffer minibuffer-setup-hook))) + +(ert-deftest test-font-config-fontaine-unknown-label-has-no-profile () + "Error: an unknown destination label does not select a preset." + (skip-unless test-font-config--available) + (require 'font-config) + (should-not (cj/fontaine-profile-from-label "Missing profile"))) + +(ert-deftest test-font-config-fontaine-annotation-marks-current-profile () + "Normal: completion marks only the active workflow destination." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((fontaine-current-preset 'writing)) + (should (equal (cj/fontaine-profile-annotation + (cj/fontaine-profile-label 'writing)) + " current")) + (should (equal (cj/fontaine-profile-annotation + (cj/fontaine-profile-label 'coding-m)) + "")))) + +(ert-deftest test-font-config-fontaine-selector-applies-picked-profile () + "Normal: the one-prompt picker maps its complete label before applying." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((picked (cj/fontaine-profile-label 'presentation)) + (applied nil)) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _choices &rest _) picked)) + ((symbol-function 'cj/fontaine-apply-profile) + (lambda (profile) (setq applied profile)))) + (cj/fontaine-select-profile) + (should (eq applied 'presentation))))) + +(ert-deftest test-font-config-fontaine-restores-valid-profile () + "Normal: startup restores a persisted workflow profile." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-restore-latest-preset) + (lambda () 'writing))) + (should (eq (cj/fontaine-restored-or-default-profile) 'writing)))) + +(ert-deftest test-font-config-fontaine-rejects-obsolete-restored-profile () + "Boundary: an old brand or point-size preset falls back to everyday." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-restore-latest-preset) + (lambda () '13-point-font))) + (should (eq (cj/fontaine-restored-or-default-profile) 'everyday)))) + +(ert-deftest test-font-config-fontaine-has-no-per-frame-reset-hook () + "Boundary: creating a daemon frame cannot overwrite the active profile." + (skip-unless test-font-config--available) + (require 'font-config) + (should-not (memq 'cj/apply-font-settings-to-frame + server-after-make-frame-hook)) + (should-not (memq 'cj/cleanup-frame-list delete-frame-functions))) + +(ert-deftest test-font-config-fontaine-apply-records-profile-for-persistence () + "Normal: applying a profile updates Fontaine history before setting it." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((fontaine-preset-history nil) + (applied nil)) + (cl-letf (((symbol-function 'fontaine-set-preset) + (lambda (profile) (setq applied profile)))) + (cj/fontaine-apply-profile 'coding-m) + (should (eq applied 'coding-m)) + (should (equal (car fontaine-preset-history) "coding-m"))))) + +(ert-deftest test-font-config-fontaine-apply-rejects-unknown-profile () + "Error: applying an unknown workflow profile signals a user error." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-set-preset) + (lambda (_profile) (ert-fail "must not apply")))) + (should-error (cj/fontaine-apply-profile 'missing) :type 'user-error))) + (provide 'test-font-config) ;;; test-font-config.el ends here diff --git a/tests/test-help-utils--arch-wiki-search.el b/tests/test-help-utils--arch-wiki-search.el new file mode 100644 index 00000000..d02dd041 --- /dev/null +++ b/tests/test-help-utils--arch-wiki-search.el @@ -0,0 +1,124 @@ +;;; test-help-utils--arch-wiki-search.el --- Tests for the ArchWiki search guard -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for cj/--arch-wiki-topics and the cj/local-arch-wiki-search command. +;; +;; The bug: the command read "/usr/share/doc/arch-wiki/html/en" with +;; `directory-files' before checking the directory existed. On a machine +;; without arch-wiki-docs -- the exact state the command's own error text is +;; written for -- that signaled file-missing on the first line, so the friendly +;; "Is arch-wiki-docs installed?" message below it was unreachable. The user +;; got a raw Lisp error naming a path instead of the install hint. +;; +;; Two things had to change to make this testable. The directory was +;; hardcoded inside the command, so a test could only ever exercise whatever +;; the developer's own machine happened to have installed; it is now +;; `cj/arch-wiki-html-dir'. And the directory read is now the pure helper +;; cj/--arch-wiki-topics, which takes a directory and returns an alist, so the +;; interesting cases are driven with real temporary directories instead of +;; mocking `directory-files'. +;; +;; Test organization: +;; - Normal Cases: topics found and returned; the command opens the choice +;; - Boundary Cases: empty dir, single topic, a name matching no topic +;; - Error Cases: missing dir returns nil and reports the install hint +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'help-utils) + +(defmacro test-arch-wiki--with-topics (dir-var topics &rest body) + "Bind DIR-VAR to a temp dir holding TOPICS (a list of html basenames). +The directory is removed after BODY." + (declare (indent 2)) + `(let ((,dir-var (make-temp-file "arch-wiki-test" t))) + (unwind-protect + (progn + (dolist (name ,topics) + (write-region "" nil (expand-file-name (concat name ".html") ,dir-var))) + ,@body) + (delete-directory ,dir-var t)))) + +;;; Normal Cases — the pure helper + +(ert-deftest test-help-utils-arch-wiki-topics-lists-html-basenames () + "Normal: each .html file becomes a (basename . fullpath) pair." + (test-arch-wiki--with-topics dir '("Systemd" "Pacman") + (let ((topics (cj/--arch-wiki-topics dir))) + (should (equal '("Pacman" "Systemd") (sort (mapcar #'car topics) #'string<))) + (should (string-suffix-p "Systemd.html" (cdr (assoc "Systemd" topics))))))) + +(ert-deftest test-help-utils-arch-wiki-topics-ignores-non-html () + "Normal: files without the .html extension are not topics." + (test-arch-wiki--with-topics dir '("Systemd") + (write-region "" nil (expand-file-name "README.txt" dir)) + (should (equal '("Systemd") (mapcar #'car (cj/--arch-wiki-topics dir)))))) + +;;; Boundary Cases + +(ert-deftest test-help-utils-arch-wiki-topics-empty-dir-is-nil () + "Boundary: an existing but empty directory yields no topics." + (test-arch-wiki--with-topics dir '() + (should (null (cj/--arch-wiki-topics dir))))) + +(ert-deftest test-help-utils-arch-wiki-topics-single-topic () + "Boundary: one topic returns a one-element alist." + (test-arch-wiki--with-topics dir '("Systemd") + (should (= 1 (length (cj/--arch-wiki-topics dir)))))) + +;;; Error Cases — the missing-install path + +(ert-deftest test-help-utils-arch-wiki-topics-missing-dir-returns-nil () + "Error: an absent directory returns nil rather than signaling file-missing." + (let ((missing (expand-file-name "definitely-absent-arch-wiki" + temporary-file-directory))) + (should-not (file-directory-p missing)) + (should (null (cj/--arch-wiki-topics missing))))) + +(ert-deftest test-help-utils-arch-wiki-search-missing-dir-reports-hint () + "Error: the command reports the install hint and opens nothing." + (let ((cj/arch-wiki-html-dir (expand-file-name "definitely-absent-arch-wiki" + temporary-file-directory)) + (said nil) + (opened nil)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq said (apply #'format fmt args)) nil)) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + ;; Must not signal: this is the case that used to raise file-missing. + (cj/local-arch-wiki-search)) + (should-not opened) + (should (string-match-p "arch-wiki-docs" said)))) + +;;; Normal Cases — the command + +(ert-deftest test-help-utils-arch-wiki-search-opens-chosen-topic () + "Normal: the chosen topic is opened as a file URL in EWW." + (test-arch-wiki--with-topics dir '("Systemd") + (let ((cj/arch-wiki-html-dir dir) + (opened nil)) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "Systemd")) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + (cj/local-arch-wiki-search)) + (should (string-prefix-p "file://" opened)) + (should (string-suffix-p "Systemd.html" opened)) + ;; The opened path is the one in the temp dir, not a system copy. + (should (string-match-p (regexp-quote dir) opened))))) + +(ert-deftest test-help-utils-arch-wiki-search-unknown-topic-opens-nothing () + "Boundary: a name matching no topic reports rather than opening." + (test-arch-wiki--with-topics dir '("Systemd") + (let ((cj/arch-wiki-html-dir dir) + (opened nil)) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "NotATopic")) + ((symbol-function 'message) (lambda (&rest _) nil)) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + (cj/local-arch-wiki-search)) + (should-not opened)))) + +(provide 'test-help-utils--arch-wiki-search) +;;; test-help-utils--arch-wiki-search.el ends here diff --git a/tests/test-host-environment--detect-system-timezone.el b/tests/test-host-environment--detect-system-timezone.el index 209283d1..0d76c206 100644 --- a/tests/test-host-environment--detect-system-timezone.el +++ b/tests/test-host-environment--detect-system-timezone.el @@ -17,12 +17,23 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'host-environment) -(ert-deftest test-host-environment-detect-tz-match-localtime-wins () - "Normal: when match-localtime-to-zoneinfo returns a value, that wins." +(ert-deftest test-host-environment-detect-tz-env-wins-without-content-scan () + "Normal: an explicit TZ wins and the exhaustive zoneinfo scan never runs. +The scan reads hundreds of files; it used to run first on every call even +when a cheap O(1) method would answer." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) - (lambda () "America/Los_Angeles")) + (lambda () (error "content scan should not have run"))) ((symbol-function 'getenv) - (lambda (_ &rest _) (error "TZ should not have been consulted")))) + (lambda (name &rest _) (when (string= name "TZ") "America/Chicago")))) + (should (equal (cj/detect-system-timezone) "America/Chicago")))) + +(ert-deftest test-host-environment-detect-tz-content-scan-is-last-resort () + "Boundary: with every cheap method empty, the content scan still answers." + (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) + (lambda () "America/Los_Angeles")) + ((symbol-function 'getenv) (lambda (&rest _) nil)) + ((symbol-function 'file-exists-p) (lambda (&rest _) nil)) + ((symbol-function 'file-symlink-p) (lambda (&rest _) nil))) (should (equal (cj/detect-system-timezone) "America/Los_Angeles")))) (ert-deftest test-host-environment-detect-tz-env-var-wins-when-match-nil () diff --git a/tests/test-httpd-config--defer.el b/tests/test-httpd-config--defer.el new file mode 100644 index 00000000..1a1fbbed --- /dev/null +++ b/tests/test-httpd-config--defer.el @@ -0,0 +1,34 @@ +;;; test-httpd-config--defer.el --- Tests for httpd-config lazy loading -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins httpd-config's load-time behavior: merely loading the module must +;; not create the www directory (that belongs to the moment simple-httpd +;; actually loads) and must not pull in simple-httpd itself — +;; impatient-mode requires it on demand. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) + +;;; Boundary Cases + +(ert-deftest test-httpd-config-load-creates-no-www-dir () + "Boundary: loading httpd-config does not create www/ in user-emacs-directory." + (let* ((sandbox (make-temp-file "httpd-config-test-" t)) + (user-emacs-directory (file-name-as-directory sandbox))) + (unwind-protect + (progn + (require 'httpd-config) + (should-not (file-directory-p + (expand-file-name "www" user-emacs-directory)))) + (delete-directory sandbox t)))) + +(ert-deftest test-httpd-config-load-does-not-load-simple-httpd () + "Boundary: loading httpd-config leaves simple-httpd unloaded." + (require 'httpd-config) + (should-not (featurep 'simple-httpd))) + +(provide 'test-httpd-config--defer) +;;; test-httpd-config--defer.el ends here diff --git a/tests/test-hugo-config--keymap.el b/tests/test-hugo-config--keymap.el new file mode 100644 index 00000000..0f8df257 --- /dev/null +++ b/tests/test-hugo-config--keymap.el @@ -0,0 +1,71 @@ +;;; test-hugo-config--keymap.el --- Tests for the Hugo prefix keymap -*- lexical-binding: t; -*- + +;;; Commentary: +;; Pins the eight Hugo commands reachable under the "C-; h" prefix. +;; +;; The module used to install these with eight raw `global-set-key' calls plus +;; a hand-written which-key block, writing into the global map directly instead +;; of going through `cj/register-prefix-map' the way its siblings +;; (erc-config, custom-ordering, org-reveal-config) do. These tests were added +;; alongside that conversion so the refactor is checkable: every key must still +;; reach the same command afterward. +;; +;; Test organization: +;; - Normal Cases: each of the eight keys resolves to its command +;; - Boundary Cases: case-distinct pairs stay distinct; the map is a prefix map +;; - Error Cases: an unbound key in the map resolves to nothing +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(provide 'ox-hugo) +(require 'hugo-config) +(require 'keybindings) + +(defconst test-hugo--expected-bindings + '(("n" . cj/hugo-new-post) + ("e" . cj/hugo-export-post) + ("o" . cj/hugo-open-blog-dir) + ("O" . cj/hugo-open-blog-dir-external) + ("d" . cj/hugo-open-draft) + ("D" . cj/hugo-toggle-draft) + ("p" . cj/hugo-preview) + ("P" . cj/hugo-publish)) + "Every key the Hugo prefix map must carry, and the command it runs.") + +;;; Normal Cases + +(ert-deftest test-hugo-config-keymap-binds-every-command () + "Normal: each Hugo key resolves to its command inside the prefix map." + (dolist (pair test-hugo--expected-bindings) + (should (eq (cdr pair) (keymap-lookup cj/hugo-keymap (car pair)))))) + +(ert-deftest test-hugo-config-keymap-registered-under-custom-prefix () + "Normal: the map is reachable at \"h\" within `cj/custom-keymap'." + (should (eq cj/hugo-keymap (keymap-lookup cj/custom-keymap "h")))) + +;;; Boundary Cases + +(ert-deftest test-hugo-config-keymap-case-pairs-stay-distinct () + "Boundary: the shifted variants run different commands than their lowercase +counterparts, which a case-folding binding would silently collapse." + (should-not (eq (keymap-lookup cj/hugo-keymap "o") + (keymap-lookup cj/hugo-keymap "O"))) + (should-not (eq (keymap-lookup cj/hugo-keymap "d") + (keymap-lookup cj/hugo-keymap "D"))) + (should-not (eq (keymap-lookup cj/hugo-keymap "p") + (keymap-lookup cj/hugo-keymap "P")))) + +(ert-deftest test-hugo-config-keymap-is-a-keymap () + "Boundary: the value registered as a prefix is an actual keymap." + (should (keymapp cj/hugo-keymap))) + +;;; Error Cases + +(ert-deftest test-hugo-config-keymap-unbound-key-is-nil () + "Error: a key the map does not define resolves to nothing." + (should-not (keymap-lookup cj/hugo-keymap "z"))) + +(provide 'test-hugo-config--keymap) +;;; test-hugo-config--keymap.el ends here diff --git a/tests/test-integration-recording-device-workflow.el b/tests/test-integration-recording-device-workflow.el index 3ef631f3..27ffac56 100644 --- a/tests/test-integration-recording-device-workflow.el +++ b/tests/test-integration-recording-device-workflow.el @@ -1,26 +1,24 @@ ;;; test-integration-recording-device-workflow.el --- Integration tests for recording device workflow -*- lexical-binding: t; -*- ;;; Commentary: -;; Integration tests covering the complete device detection and grouping workflow. -;; -;; This tests the full pipeline from raw pactl output through parsing, grouping, -;; and friendly name assignment. The workflow enables users to select audio devices -;; for recording calls/meetings. +;; Integration test covering the device detection path that recording actually +;; uses: raw pactl output through parsing and into friendly state names. ;; ;; Components integrated: ;; - cj/recording--parse-pactl-output (parse raw pactl output into structured data) -;; - cj/recording-parse-sources (shell command wrapper) -;; - cj/recording-group-devices-by-hardware (group inputs/monitors by device) +;; - cj/recording-parse-sources (shell command wrapper, MOCKED at +;; shell-command-to-string so no pactl runs) ;; - cj/recording-friendly-state (convert technical state names) -;; - Bluetooth MAC address normalization (colons → underscores) -;; - Device name pattern matching (USB, PCI, Bluetooth) -;; - Friendly name assignment (user-facing device names) ;; ;; Critical integration points: -;; - Parse output must produce data that group-devices can process -;; - Bluetooth MAC normalization must work across parse→group boundary -;; - Incomplete devices (only mic OR only monitor) must be filtered -;; - Friendly names must correctly identify device types +;; - Parse output must carry device state through to the friendly-name conversion +;; +;; This file once covered a parse-to-group pipeline as well. That half tested +;; cj/recording-group-devices-by-hardware, a second device-grouping +;; implementation nothing ever called -- cj/recording-select-device is the live +;; selection path and reaches parse-sources directly. The function and its +;; tests were removed rather than left as coverage that proved an unused code +;; path worked. ;;; Code: @@ -46,58 +44,6 @@ ;;; Normal Cases - Complete Workflow -(ert-deftest test-integration-recording-device-workflow-parse-to-group-all-devices () - "Test complete workflow from pactl output to grouped devices. - -When pactl output contains all three device types (built-in, USB, Bluetooth), -the workflow should parse, group, and assign friendly names to all devices. - -Components integrated: -- cj/recording--parse-pactl-output (parsing) -- cj/recording-group-devices-by-hardware (grouping + MAC normalization) -- Device pattern matching (USB/PCI/Bluetooth detection) -- Friendly name assignment - -Validates: -- All three device types are detected -- Bluetooth MAC addresses normalized (colons → underscores) -- Each device has both mic and monitor -- Friendly names correctly assigned -- Complete data flow: raw output → parsed list → grouped pairs" - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - ;; Test parse step - (let ((parsed (cj/recording-parse-sources))) - (should (= 6 (length parsed))) - - ;; Test group step (receives parsed data) - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 3 (length grouped))) - - ;; Validate built-in device - (let ((built-in (assoc "Built-in Audio" grouped))) - (should built-in) - (should (string-prefix-p "alsa_input.pci" (cadr built-in))) - (should (string-prefix-p "alsa_output.pci" (cddr built-in)))) - - ;; Validate USB device - (let ((usb (assoc "Jabra SPEAK 510 USB" grouped))) - (should usb) - (should (string-match-p "Jabra" (cadr usb))) - (should (string-match-p "Jabra" (cddr usb)))) - - ;; Validate Bluetooth device (CRITICAL: MAC normalization) - (let ((bluetooth (assoc "Bluetooth Headset" grouped))) - (should bluetooth) - ;; Input has colons - (should (string-match-p "00:1B:66:C0:91:6D" (cadr bluetooth))) - ;; Output has underscores - (should (string-match-p "00_1B_66_C0_91_6D" (cddr bluetooth))) - ;; But they're grouped together! - (should (equal "bluez_input.00:1B:66:C0:91:6D" (cadr bluetooth))) - (should (equal "bluez_output.00_1B_66_C0_91_6D.1.monitor" (cddr bluetooth))))))))) - (ert-deftest test-integration-recording-device-workflow-friendly-states-in-list () "Test that friendly state names appear in device list output. @@ -128,105 +74,5 @@ Validates: ;;; Boundary Cases - Incomplete Devices -(ert-deftest test-integration-recording-device-workflow-incomplete-devices-filtered () - "Test that devices with only mic OR only monitor are filtered out. - -For call recording, we need BOTH mic and monitor from the same device. -Incomplete devices should not appear in the grouped output. - -Components integrated: -- cj/recording-parse-sources (parsing all devices) -- cj/recording-group-devices-by-hardware (filtering incomplete pairs) - -Validates: -- Device with only mic is filtered -- Device with only monitor is filtered -- Only complete devices (both mic and monitor) are returned -- Filtering happens at group stage, not parse stage" - (let ((output (concat - ;; Complete device - "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - "49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - ;; Incomplete: USB mic with no monitor - "100\talsa_input.usb-device.mono-fallback\tPipeWire\ts16le 1ch 16000Hz\tSUSPENDED\n" - ;; Incomplete: Bluetooth monitor with no mic - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - ;; Parse sees all 4 devices - (let ((parsed (cj/recording-parse-sources))) - (should (= 4 (length parsed))) - - ;; Group returns only 1 complete device - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 1 (length grouped))) - (should (equal "Built-in Audio" (caar grouped)))))))) - -;;; Edge Cases - Bluetooth MAC Normalization - -(ert-deftest test-integration-recording-device-workflow-bluetooth-mac-variations () - "Test Bluetooth MAC normalization with different formats. - -Bluetooth devices use colons in input names but underscores in output names. -The grouping must normalize these to match devices correctly. - -Components integrated: -- cj/recording-parse-sources (preserves original MAC format) -- cj/recording-group-devices-by-hardware (normalizes MAC for matching) -- Base name extraction (regex patterns) -- MAC address transformation (underscores → colons) - -Validates: -- Input with colons (bluez_input.AA:BB:CC:DD:EE:FF) parsed correctly -- Output with underscores (bluez_output.AA_BB_CC_DD_EE_FF) parsed correctly -- Normalization happens during grouping -- Devices paired despite format difference -- Original device names preserved (not mutated)" - (let ((output (concat - "79\tbluez_input.11:22:33:44:55:66\tPipeWire\tfloat32le 1ch 48000Hz\tSUSPENDED\n" - "81\tbluez_output.11_22_33_44_55_66.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((parsed (cj/recording-parse-sources))) - ;; Original formats preserved in parse - (should (string-match-p "11:22:33" (caar parsed))) - (should (string-match-p "11_22_33" (caadr parsed))) - - ;; But grouping matches them - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 1 (length grouped))) - (should (equal "Bluetooth Headset" (caar grouped))) - ;; Original names preserved - (should (equal "bluez_input.11:22:33:44:55:66" (cadar grouped))) - (should (equal "bluez_output.11_22_33_44_55_66.1.monitor" (cddar grouped)))))))) - -;;; Error Cases - Malformed Data - -(ert-deftest test-integration-recording-device-workflow-malformed-output-handled () - "Test that malformed pactl output is handled gracefully. - -When pactl output is malformed or unparseable, the workflow should not crash. -It should return empty results at appropriate stages. - -Components integrated: -- cj/recording--parse-pactl-output (malformed line handling) -- cj/recording-group-devices-by-hardware (empty input handling) - -Validates: -- Malformed lines are silently skipped during parse -- Empty parse results don't crash grouping -- Workflow degrades gracefully -- No exceptions thrown" - (let ((output (test-load-fixture "pactl-output-malformed.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((parsed (cj/recording-parse-sources))) - ;; Malformed output produces empty parse - (should (null parsed)) - - ;; Empty parse produces empty grouping (no crash) - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (null grouped))))))) - (provide 'test-integration-recording-device-workflow) ;;; test-integration-recording-device-workflow.el ends here diff --git a/tests/test-jumper.el b/tests/test-jumper.el index fa65d3f4..638f2aa2 100644 --- a/tests/test-jumper.el +++ b/tests/test-jumper.el @@ -348,5 +348,30 @@ (should (string-match-p "test line" formatted)))) (test-jumper-teardown)) +;;; Empty completing-read input (vertico-less UI can return "") + +(ert-deftest test-jumper-jump-empty-choice-signals-user-error () + "Error: empty input at the jump prompt gives a user-error, not a crash. +An unmatched choice makes (cdr (assoc ...)) nil, which used to flow into +the index arithmetic and signal wrong-type-argument." + (let ((jumper--next-index 2)) + (cl-letf (((symbol-function 'jumper--location-candidates) + (lambda () '(("[0] here" . 0) ("[1] there" . 1)))) + ((symbol-function 'get-register) (lambda (_r) nil)) + ((symbol-function 'completing-read) (lambda (&rest _) ""))) + (should-error (jumper-jump-to-location) :type 'user-error)))) + +(ert-deftest test-jumper-remove-empty-choice-cancels () + "Boundary: empty input at the remove prompt cancels instead of crashing." + (let ((jumper--next-index 2) + removed) + (cl-letf (((symbol-function 'jumper--location-candidates) + (lambda () '(("[0] here" . 0) ("[1] there" . 1)))) + ((symbol-function 'completing-read) (lambda (&rest _) "")) + ((symbol-function 'jumper--reorder-registers) + (lambda (_i) (setq removed t)))) + (jumper-remove-location) + (should-not removed)))) + (provide 'test-jumper) ;;; test-jumper.el ends here diff --git a/tests/test-media-utils--argv.el b/tests/test-media-utils--argv.el new file mode 100644 index 00000000..81317b60 --- /dev/null +++ b/tests/test-media-utils--argv.el @@ -0,0 +1,72 @@ +;;; test-media-utils--argv.el --- Tests for media-utils argv builders -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for the pure helpers behind cj/media-play-it's shell-free +;; launch: cj/media--yt-dlp-argv (stream-URL resolution command), +;; cj/media--stream-urls (yt-dlp -g output parsing), and +;; cj/media--play-argv (player launch argv). Argv lists are the +;; hardening: URLs and args never meet a shell. +;; +;; Test organization: +;; - Normal Cases: formats present/absent, args split, multi-line output +;; - Boundary Cases: metacharacter URLs verbatim, empty output, nil args +;; - Error Cases: none (builders are total; error paths live in the caller) +;; +;;; Code: + +(require 'ert) +(require 'media-utils) + +;;; cj/media--yt-dlp-argv + +(ert-deftest test-media-utils--yt-dlp-argv-normal-with-formats () + "Normal: formats join with / behind -f, URL last." + (should (equal (cj/media--yt-dlp-argv "https://example.com/v" '("22" "18" "best")) + '("yt-dlp" "-f" "22/18/best" "-g" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dlp-argv-normal-without-formats () + "Normal: nil formats drops the -f pair." + (should (equal (cj/media--yt-dlp-argv "https://example.com/v" nil) + '("yt-dlp" "-g" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dlp-argv-boundary-metacharacter-url () + "Boundary: a URL with shell metacharacters stays one verbatim element." + (let ((url "https://example.com/v?a=1&b=$(x);c='d'")) + (should (equal (car (last (cj/media--yt-dlp-argv url nil))) url)))) + +;;; cj/media--stream-urls + +(ert-deftest test-media-utils--stream-urls-normal-two-lines () + "Normal: each non-empty output line is one stream URL." + (should (equal (cj/media--stream-urls "https://a/video\nhttps://a/audio\n") + '("https://a/video" "https://a/audio")))) + +(ert-deftest test-media-utils--stream-urls-boundary-blank-and-crlf () + "Boundary: blank lines and CR line endings are stripped." + (should (equal (cj/media--stream-urls "https://a/v\r\n\n \nhttps://a/u\r\n") + '("https://a/v" "https://a/u")))) + +(ert-deftest test-media-utils--stream-urls-boundary-empty-output () + "Boundary: empty output yields nil." + (should-not (cj/media--stream-urls ""))) + +;;; cj/media--play-argv + +(ert-deftest test-media-utils--play-argv-normal-args-split () + "Normal: the player's raw args string splits into argv words." + (should (equal (cj/media--play-argv "vlc" "--no-video --intf dummy" + '("https://a/v")) + '("vlc" "--no-video" "--intf" "dummy" "https://a/v")))) + +(ert-deftest test-media-utils--play-argv-boundary-nil-args () + "Boundary: nil args yields program + URLs only." + (should (equal (cj/media--play-argv "mpv" nil '("https://a/v")) + '("mpv" "https://a/v")))) + +(ert-deftest test-media-utils--play-argv-boundary-multiple-urls () + "Boundary: every resolved stream URL is appended in order." + (should (equal (cj/media--play-argv "mpv" nil '("https://a/v" "https://a/u")) + '("mpv" "https://a/v" "https://a/u")))) + +(provide 'test-media-utils--argv) +;;; test-media-utils--argv.el ends here diff --git a/tests/test-media-utils--yt-dl-message.el b/tests/test-media-utils--yt-dl-message.el new file mode 100644 index 00000000..491b64cf --- /dev/null +++ b/tests/test-media-utils--yt-dl-message.el @@ -0,0 +1,64 @@ +;;; test-media-utils--yt-dl-message.el --- Tests for the yt-dl sentinel message -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for cj/media--yt-dl-message, the pure helper behind +;; cj/yt-dl-it's process sentinel. +;; +;; The behavior under test is a correctness fix, not cosmetics. cj/yt-dl-it +;; launches "tsp yt-dlp ...", and tsp enqueues the job and exits immediately. +;; The sentinel therefore fires on tsp's exit, not on yt-dlp's, so the old +;; "Finished downloading" text claimed a completed download at the moment the +;; download was merely queued -- and a yt-dlp failure minutes later was silent. +;; The helper reports queueing, which is the only thing tsp's exit actually +;; proves. +;; +;; Test organization: +;; - Normal Cases: clean tsp exit reports queued; abnormal exit reports failure +;; - Boundary Cases: unrelated events return nil; URL text passes through verbatim +;; - Error Cases: empty event string returns nil +;; +;;; Code: + +(require 'ert) +(require 'media-utils) + +;;; Normal Cases + +(ert-deftest test-media-utils--yt-dl-message-normal-finished-says-queued () + "Normal: a clean tsp exit reports the job queued, never downloaded." + (let ((msg (cj/media--yt-dl-message "finished\n" "https://example.com/v"))) + (should (string-match-p "[Qq]ueued" msg)) + (should-not (string-match-p "[Ff]inished downloading" msg)))) + +(ert-deftest test-media-utils--yt-dl-message-normal-abnormal-reports-failure () + "Normal: an abnormal tsp exit reports that queueing failed." + (let ((msg (cj/media--yt-dl-message "exited abnormally with code 1\n" + "https://example.com/v"))) + (should msg) + (should-not (string-match-p "[Qq]ueued for" msg)))) + +;;; Boundary Cases + +(ert-deftest test-media-utils--yt-dl-message-boundary-unrelated-event-is-nil () + "Boundary: an event that reports neither outcome produces no message." + (should (null (cj/media--yt-dl-message "run\n" "https://example.com/v"))) + (should (null (cj/media--yt-dl-message "stopped\n" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dl-message-boundary-url-passes-through () + "Boundary: the URL text is carried into the message verbatim." + (let ((url "https://example.com/watch?v=a&b=c%20d")) + (should (string-match-p (regexp-quote url) + (cj/media--yt-dl-message "finished\n" url))))) + +(ert-deftest test-media-utils--yt-dl-message-boundary-empty-url () + "Boundary: an empty URL still yields a message rather than signaling." + (should (stringp (cj/media--yt-dl-message "finished\n" "")))) + +;;; Error Cases + +(ert-deftest test-media-utils--yt-dl-message-error-empty-event-is-nil () + "Error: an empty event string matches no outcome and returns nil." + (should (null (cj/media--yt-dl-message "" "https://example.com/v")))) + +(provide 'test-media-utils--yt-dl-message) +;;; test-media-utils--yt-dl-message.el ends here diff --git a/tests/test-media-utils.el b/tests/test-media-utils.el index 841b6faf..23b36eeb 100644 --- a/tests/test-media-utils.el +++ b/tests/test-media-utils.el @@ -38,34 +38,41 @@ ;; ----------------------------- cj/media-play-it ------------------------------ (ert-deftest test-media-play-it-direct-playback-command () - "Normal: a player that needs no stream URL gets a plain command, no yt-dlp." + "Normal: a player that needs no stream URL launches an argv process, no yt-dlp." (let (captured cj/default-media-player) (setq cj/default-media-player 'mpv) (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/mpv")) - ((symbol-function 'start-process-shell-command) - (lambda (_n _b cmd) (setq captured cmd) 'proc)) + ((symbol-function 'start-process) + (lambda (&rest args) (setq captured args) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) ((symbol-function 'message) #'ignore) ((symbol-function 'cj/log-silently) #'ignore)) (cj/media-play-it "https://example.com/v")) - (should (string-match-p "mpv" captured)) - (should (string-match-p "example\\.com" captured)) - (should-not (string-match-p "yt-dlp" captured)))) - -(ert-deftest test-media-play-it-stream-url-wraps-yt-dlp () - "Normal: a player needing a stream URL wraps the URL in a yt-dlp -g call." - (let (captured cj/default-media-player) + ;; (NAME BUFFER PROGRAM . ARGS) -- program + args are the argv. + (should (equal (nthcdr 2 captured) '("mpv" "https://example.com/v"))) + (should-not (member "yt-dlp" captured)))) + +(ert-deftest test-media-play-it-stream-url-resolves-via-yt-dlp () + "Normal: a stream-URL player resolves through a yt-dlp -g capture, then +launches the player with the resolved URL as argv -- no shell either step." + (let (yt-argv captured cj/default-media-player) (setq cj/default-media-player 'vlc) - (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/vlc")) - ((symbol-function 'start-process-shell-command) - (lambda (_n _b cmd) (setq captured cmd) 'proc)) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) + ((symbol-function 'call-process) + (lambda (program _infile _dest _display &rest args) + (setq yt-argv (cons program args)) + (insert "https://stream.example.com/resolved\n") + 0)) + ((symbol-function 'start-process) + (lambda (&rest args) (setq captured args) 'proc)) ((symbol-function 'set-process-sentinel) #'ignore) ((symbol-function 'message) #'ignore) ((symbol-function 'cj/log-silently) #'ignore)) (cj/media-play-it "https://example.com/v")) - (should (string-match-p "yt-dlp" captured)) - (should (string-match-p "-g" captured)) - (should (string-match-p "-f 22/18/best" captured)))) + (should (equal yt-argv + '("yt-dlp" "-f" "22/18/best" "-g" "https://example.com/v"))) + (should (equal (nthcdr 2 captured) + '("vlc" "https://stream.example.com/resolved"))))) (ert-deftest test-media-play-it-missing-player-errors () "Error: an unavailable player command signals an error before launching." @@ -74,6 +81,73 @@ (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) nil))) (should-error (cj/media-play-it "https://example.com/v"))))) +(ert-deftest test-media-play-it-missing-yt-dlp-errors () + "Error: a stream-URL player with no yt-dlp on PATH aborts before resolving." + (let (cj/default-media-player) + (setq cj/default-media-player 'vlc) + (cl-letf (((symbol-function 'executable-find) + (lambda (cmd &rest _) (and (equal cmd "vlc") "/usr/bin/vlc")))) + (should-error (cj/media-play-it "https://example.com/v"))))) + +(ert-deftest test-media-play-it-yt-dlp-failure-errors () + "Error: a non-zero yt-dlp exit surfaces as an error, player never launches." + (let (launched cj/default-media-player) + (setq cj/default-media-player 'vlc) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) + ((symbol-function 'call-process) + (lambda (&rest _) (insert "ERROR: no video\n") 1)) + ((symbol-function 'start-process) + (lambda (&rest _) (setq launched t) 'proc)) + ((symbol-function 'message) #'ignore)) + (should-error (cj/media-play-it "https://example.com/v"))) + (should-not launched))) + +(ert-deftest test-media-play-it-yt-dlp-empty-output-errors () + "Error: a zero-exit yt-dlp with no output still errors, player never launches." + (let (launched cj/default-media-player) + (setq cj/default-media-player 'vlc) + (cl-letf (((symbol-function 'executable-find) (lambda (_ &rest _) "/usr/bin/x")) + ((symbol-function 'call-process) (lambda (&rest _) 0)) + ((symbol-function 'start-process) + (lambda (&rest _) (setq launched t) 'proc)) + ((symbol-function 'message) #'ignore)) + (should-error (cj/media-play-it "https://example.com/v"))) + (should-not launched))) + +;; -------------------------- cj/media--play-sentinel -------------------------- + +(ert-deftest test-media-utils--play-sentinel-normal-finished-kills-buffer () + "Normal: a finished event reports success and reaps the process buffer." + (let ((buf (generate-new-buffer " *sentinel-test*")) + (said nil)) + (cl-letf (((symbol-function 'process-buffer) (lambda (_p) buf)) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq said (apply #'format fmt args))))) + (funcall (cj/media--play-sentinel "https://a/v") 'proc "finished\n")) + (should (string-match-p "Finished" said)) + (should-not (buffer-live-p buf)))) + +(ert-deftest test-media-utils--play-sentinel-normal-abnormal-exit-kills-buffer () + "Normal: an abnormal exit reports failure and reaps the process buffer." + (let ((buf (generate-new-buffer " *sentinel-test*")) + (said nil)) + (cl-letf (((symbol-function 'process-buffer) (lambda (_p) buf)) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq said (apply #'format fmt args))))) + (funcall (cj/media--play-sentinel "https://a/v") 'proc "exited abnormally with code 2\n")) + (should (string-match-p "failed" said)) + (should-not (buffer-live-p buf)))) + +(ert-deftest test-media-utils--play-sentinel-boundary-other-event-keeps-buffer () + "Boundary: a non-terminal event (e.g. stop) leaves the buffer alone." + (let ((buf (generate-new-buffer " *sentinel-test*"))) + (unwind-protect + (cl-letf (((symbol-function 'process-buffer) (lambda (_p) buf)) + ((symbol-function 'message) #'ignore)) + (funcall (cj/media--play-sentinel "https://a/v") 'proc "stopped\n") + (should (buffer-live-p buf))) + (when (buffer-live-p buf) (kill-buffer buf))))) + ;; ------------------------------- cj/yt-dl-it --------------------------------- (ert-deftest test-media-yt-dl-it-errors-without-yt-dlp () diff --git a/tests/test-music-config--add-dired-selection.el b/tests/test-music-config--add-dired-selection.el new file mode 100644 index 00000000..9380409c --- /dev/null +++ b/tests/test-music-config--add-dired-selection.el @@ -0,0 +1,64 @@ +;;; test-music-config--add-dired-selection.el --- Tests for dired add command -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for cj/music-add-dired-selection. +;; +;; Test organization: +;; - Normal Cases: marked files (no region) are all queued +;; - Boundary Cases: no marks falls back to the file at point +;; - Error Cases: outside dired signals a user-error +;; +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; Stub missing dependencies before loading music-config +(defvar-keymap cj/custom-keymap + :doc "Stub keymap for testing") + +;; Add EMMS elpa directory to load path for batch testing +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir + (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(defun test-add-dired--run (marked) + "Run the command with MARKED as dired's marked-file answer; return added files." + (let (added) + (cl-letf (((symbol-function 'derived-mode-p) (lambda (&rest _) t)) + ((symbol-function 'cj/music--ensure-playlist-buffer) (lambda () nil)) + ((symbol-function 'dired-get-marked-files) + (lambda (&rest _) marked)) + ((symbol-function 'file-directory-p) (lambda (_f) nil)) + ((symbol-function 'cj/music--valid-file-p) (lambda (_f) t)) + ((symbol-function 'emms-add-file) (lambda (f) (push f added))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (cj/music-add-dired-selection) + (nreverse added)))) + +(ert-deftest test-music-add-dired-selection-queues-all-marked-files () + "Normal: files marked with m (no region) are all queued, not just point. +The old gate ran dired-get-marked-files only under use-region-p, so marks +without a region fell to the single-file branch and silently dropped all +but the point file." + (should (equal (test-add-dired--run '("/tmp/a.mp3" "/tmp/b.mp3" "/tmp/c.mp3")) + '("/tmp/a.mp3" "/tmp/b.mp3" "/tmp/c.mp3")))) + +(ert-deftest test-music-add-dired-selection-point-file-when-no-marks () + "Boundary: with no marks, dired-get-marked-files returns the point file." + (should (equal (test-add-dired--run '("/tmp/only.mp3")) + '("/tmp/only.mp3")))) + +(ert-deftest test-music-add-dired-selection-errors-outside-dired () + "Error: outside a dired buffer the command signals a user-error." + (cl-letf (((symbol-function 'derived-mode-p) (lambda (&rest _) nil))) + (should-error (cj/music-add-dired-selection) :type 'user-error))) + +(provide 'test-music-config--add-dired-selection) +;;; test-music-config--add-dired-selection.el ends here diff --git a/tests/test-music-config--after-playlist-clear.el b/tests/test-music-config--after-playlist-clear.el index c23e2b5b..42dcf0e3 100644 --- a/tests/test-music-config--after-playlist-clear.el +++ b/tests/test-music-config--after-playlist-clear.el @@ -112,5 +112,30 @@ (progn (cj/music--after-playlist-clear) nil) (error err))))) +(ert-deftest test-music-header-toggle-advice-is-named-and-installed () + "Normal: the header-refresh toggle advice is a named, removable function. +An anonymous lambda can't be advice-removed and stacks a copy on every +:config reload, firing the header refresh N times per toggle." + (should (fboundp 'cj/music--refresh-header-after-toggle)) + (dolist (fn '(emms-toggle-repeat-playlist + emms-toggle-repeat-track + emms-toggle-random-playlist + cj/music-toggle-consume)) + (should (advice-member-p #'cj/music--refresh-header-after-toggle fn)))) + +(ert-deftest test-music-header-toggle-advice-does-not-stack () + "Boundary: re-running the install (a :config reload) keeps one advice copy." + (dolist (fn '(emms-toggle-repeat-playlist emms-toggle-repeat-track)) + (advice-remove fn #'cj/music--refresh-header-after-toggle) + (advice-add fn :after #'cj/music--refresh-header-after-toggle) + (advice-remove fn #'cj/music--refresh-header-after-toggle) + (advice-add fn :after #'cj/music--refresh-header-after-toggle) + (let ((count 0)) + (advice-mapc (lambda (f _props) + (when (eq f 'cj/music--refresh-header-after-toggle) + (setq count (1+ count)))) + fn) + (should (= count 1))))) + (provide 'test-music-config--after-playlist-clear) ;;; test-music-config--after-playlist-clear.el ends here diff --git a/tests/test-music-config--completion-table.el b/tests/test-music-config--completion-table.el index 5e33e655..6b3da442 100644 --- a/tests/test-music-config--completion-table.el +++ b/tests/test-music-config--completion-table.el @@ -19,6 +19,10 @@ (defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") +;; Declare special here too (the module's bare defvar is file-local) so the +;; registration test's `let' binds dynamically. +(defvar marginalia-annotator-registry) + ;; Load production code (require 'music-config) @@ -131,5 +135,15 @@ ;; Should not crash, returns empty (should (null result)))) +;;; Marginalia registration + +(ert-deftest test-music-config--completion-table-registers-with-marginalia () + "Normal: building the table registers cj-music-file so marginalia +right-aligns the size/date annotations." + (let ((marginalia-annotator-registry '())) + (cj/music--completion-table '("a.mp3")) + (should (equal (assq 'cj-music-file marginalia-annotator-registry) + '(cj-music-file builtin none))))) + (provide 'test-music-config--completion-table) ;;; test-music-config--completion-table.el ends here diff --git a/tests/test-music-config--delete-playlist-file.el b/tests/test-music-config--delete-playlist-file.el new file mode 100644 index 00000000..ace51a4d --- /dev/null +++ b/tests/test-music-config--delete-playlist-file.el @@ -0,0 +1,135 @@ +;;; test-music-config--delete-playlist-file.el --- Tests for playlist file deletion -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for cj/music--delete-playlist-file function. +;; Tests the internal helper that removes a playlist's .m3u file, +;; clears the playlist buffer's file association when it pointed at +;; the deleted file, and refreshes the radio metadata cache. +;; +;; Test organization: +;; - Normal Cases: Existing file is deleted +;; - Boundary Cases: Association cleared only when it matches; cache refresh +;; - Error Cases: Nil path, nonexistent path +;; +;;; Code: + +(require 'ert) +(require 'testutil-general) + +;; Stub missing dependencies before loading music-config +(defvar-keymap cj/custom-keymap + :doc "Stub keymap for testing") + +;; Add EMMS elpa directory to load path for batch testing +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir + (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'emms-playlist-mode) +(require 'music-config) + +;;; Test helpers + +(defun test-delete-playlist--setup () + "Create test base dir and ensure playlist buffer exists." + (cj/create-test-base-dir) + (let ((buf (get-buffer-create cj/music-playlist-buffer-name))) + (with-current-buffer buf + (emms-playlist-mode) + (setq emms-playlist-buffer-p t)) + (setq emms-playlist-buffer buf) + buf)) + +(defun test-delete-playlist--teardown () + "Clean up test playlist buffer and temp files." + (when-let ((buf (get-buffer cj/music-playlist-buffer-name))) + (with-current-buffer buf + (setq cj/music-playlist-file nil)) + (kill-buffer buf)) + (cj/delete-test-base-dir)) + +;;; Normal Cases + +(ert-deftest test-music-config--delete-playlist-file-normal-removes-file () + "Normal: an existing playlist file is deleted from disk." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n/tmp/song.mp3\n" "playlist.m3u"))) + (cj/music--delete-playlist-file file) + (should-not (file-exists-p file))) + (test-delete-playlist--teardown))) + +;;; Boundary Cases + +(ert-deftest test-music-config--delete-playlist-file-boundary-clears-matching-association () + "Boundary: deleting the associated playlist file clears the association." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n" "playlist.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file file)) + (cj/music--delete-playlist-file file) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should-not cj/music-playlist-file))) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-boundary-keeps-other-association () + "Boundary: deleting a different file leaves the association untouched." + (test-delete-playlist--setup) + (unwind-protect + (let ((doomed (cj/create-temp-test-file-with-content + "#EXTM3U\n" "doomed.m3u")) + (kept (cj/create-temp-test-file-with-content + "#EXTM3U\n" "kept.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file kept)) + (cj/music--delete-playlist-file doomed) + (should (file-exists-p kept)) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should (equal cj/music-playlist-file kept)))) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-boundary-refreshes-radio-cache () + "Boundary: deletion clears the cached radio metadata." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n" "playlist.m3u"))) + (setq cj/music--radio-metadata-cache '(("stale" . "entry"))) + (cj/music--delete-playlist-file file) + (should-not cj/music--radio-metadata-cache)) + (test-delete-playlist--teardown))) + +;;; Error Cases + +(ert-deftest test-music-config--delete-playlist-file-error-nil-path () + "Error: nil path signals user-error." + (test-delete-playlist--setup) + (unwind-protect + (should-error (cj/music--delete-playlist-file nil) :type 'user-error) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-error-nonexistent-path () + "Error: a path that does not exist signals user-error and touches nothing." + (test-delete-playlist--setup) + (unwind-protect + (let ((kept (cj/create-temp-test-file-with-content + "#EXTM3U\n" "kept.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file kept)) + (should-error + (cj/music--delete-playlist-file + (expand-file-name "no-such.m3u" cj/test-base-dir)) + :type 'user-error) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should (equal cj/music-playlist-file kept)))) + (test-delete-playlist--teardown))) + +(provide 'test-music-config--delete-playlist-file) +;;; test-music-config--delete-playlist-file.el ends here diff --git a/tests/test-music-config--header-text.el b/tests/test-music-config--header-text.el index 8de97350..c860c6d4 100644 --- a/tests/test-music-config--header-text.el +++ b/tests/test-music-config--header-text.el @@ -139,6 +139,23 @@ (should (string-match-p "consume" plain)))) (test-header--teardown))) +(ert-deftest test-music-config--header-text-boundary-key-hints-single-save-stop () + "Header key hints: single is on 1, save is on s, and stop (S) is gone. +SPC/pause covers stop, so the S:stop hint and the [s] single / v:save hints +are retired." + (unwind-protect + (progn + (test-header--setup-playlist-buffer '("/music/a.mp3")) + (let* ((header (with-current-buffer cj/music-playlist-buffer-name + (cj/music--header-text))) + (plain (test-header--strip-properties header))) + (should (string-match-p "\\[1\\] single" plain)) + (should (string-match-p "s:save" plain)) + (should-not (string-match-p "\\[s\\] single" plain)) + (should-not (string-match-p "v:save" plain)) + (should-not (string-match-p "S:stop" plain)))) + (test-header--teardown))) + ;;; Error Cases (ert-deftest test-music-config--header-text-error-empty-playlist-shows-zero-count () diff --git a/tests/test-music-config--m3u-file-tracks.el b/tests/test-music-config--m3u-file-tracks.el index badc9817..e3cbd72e 100644 --- a/tests/test-music-config--m3u-file-tracks.el +++ b/tests/test-music-config--m3u-file-tracks.el @@ -189,5 +189,23 @@ "Parse nil input returns nil gracefully." (should (null (cj/music--m3u-file-tracks nil)))) +;;; Non-music filtering + +(ert-deftest test-music-config--m3u-file-tracks-filters-non-music-local-files () + "Normal: a local non-music path (a saved cover.jpg line) is dropped; +music files and stream URLs pass through." + (test-music-config--m3u-file-tracks-setup) + (unwind-protect + (let* ((content (concat "/home/user/music/track1.mp3\n" + "/home/user/music/album/cover.jpg\n" + "https://somafm.com/stream\n" + "/home/user/music/track2.flac\n")) + (m3u-file (cj/create-temp-test-file-with-content content "test.m3u")) + (tracks (cj/music--m3u-file-tracks m3u-file))) + (should (equal tracks '("/home/user/music/track1.mp3" + "https://somafm.com/stream" + "/home/user/music/track2.flac")))) + (test-music-config--m3u-file-tracks-teardown))) + (provide 'test-music-config--m3u-file-tracks) ;;; test-music-config--m3u-file-tracks.el ends here diff --git a/tests/test-music-config--music-files-recursive.el b/tests/test-music-config--music-files-recursive.el new file mode 100644 index 00000000..f5f5fc5b --- /dev/null +++ b/tests/test-music-config--music-files-recursive.el @@ -0,0 +1,88 @@ +;;; test-music-config--music-files-recursive.el --- Tests for filtered directory collection -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Directory adds used to hand the whole tree to emms-add-directory-tree, +;; which adds every file it finds -- cover.jpg and friends ended up as +;; playlist rows. The filtered walk returns only files passing +;; cj/music--valid-file-p, skipping hidden dirs/files, sorted. Real temp-dir +;; fixtures; the EMMS boundary is mocked only in the command-level test. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defmacro test-music-files--with-fixture (var &rest body) + "Run BODY with VAR bound to a temp music-directory fixture." + (declare (indent 1)) + `(let ((,var (make-temp-file "music-test-" t))) + (unwind-protect + (progn + (make-directory (expand-file-name "album" ,var)) + (make-directory (expand-file-name ".hidden" ,var)) + (dolist (f '("song.mp3" "cover.jpg" "album/track.flac" + "album/folder.png" "album/notes.txt" + ".hidden/secret.mp3" ".stray.ogg")) + (write-region "" nil (expand-file-name f ,var))) + ,@body) + (delete-directory ,var t)))) + +;;; Normal Cases + +(ert-deftest test-music-files-recursive-music-only () + "Normal: only files with accepted music extensions come back, sorted; +cover art, text files, and hidden entries stay out." + (test-music-files--with-fixture root + (should (equal (mapcar (lambda (f) (file-relative-name f root)) + (cj/music--music-files-recursive root)) + '("album/track.flac" "song.mp3"))))) + +(ert-deftest test-music-add-directory-recursive-adds-only-music () + "Normal: the directory-add command feeds only music files to EMMS." + (test-music-files--with-fixture root + (let (added) + (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) + (lambda () (current-buffer))) + ((symbol-function 'emms-add-file) + (lambda (f) (push f added)))) + (cj/music-add-directory-recursive root)) + (should (equal (mapcar (lambda (f) (file-relative-name f root)) + (nreverse added)) + '("album/track.flac" "song.mp3")))))) + +;;; Boundary Cases + +(ert-deftest test-music-files-recursive-case-insensitive-extensions () + "Boundary: extensions match case-insensitively (Song.MP3 counts)." + (let ((root (make-temp-file "music-test-case-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "Song.MP3" root)) + (should (= 1 (length (cj/music--music-files-recursive root))))) + (delete-directory root t)))) + +(ert-deftest test-music-files-recursive-empty-directory () + "Boundary: a directory with no music files returns nil." + (let ((root (make-temp-file "music-test-empty-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "readme.txt" root)) + (should-not (cj/music--music-files-recursive root))) + (delete-directory root t)))) + +;;; Error Cases + +(ert-deftest test-music-add-directory-recursive-not-a-directory-errors () + "Error: a non-directory argument signals user-error." + (should-error (cj/music-add-directory-recursive "/nonexistent/nowhere") + :type 'user-error)) + +(provide 'test-music-config--music-files-recursive) +;;; test-music-config--music-files-recursive.el ends here diff --git a/tests/test-music-config--pin-point.el b/tests/test-music-config--pin-point.el new file mode 100644 index 00000000..2d6fa916 --- /dev/null +++ b/tests/test-music-config--pin-point.el @@ -0,0 +1,78 @@ +;;; test-music-config--pin-point.el --- Tests for the playlist gutter cursor -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The playlist cursor lives pinned at the start of the row (the number +;; gutter). The rows are rendered track lines, not editable text, and +;; vertical motion over thumbnails and stretch-space drifts point to +;; arbitrary visual columns (usually line end). A buffer-local +;; post-command snap enforces the model for every motion command. The one +;; exception is an active isearch, which owns point placement until it ends. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +;;; Normal Cases + +(ert-deftest test-music-pin-point-snaps-mid-line-to-bol () + "Normal: point mid-row snaps back to the beginning of the line." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-char 5) + (cj/music--pin-point-to-bol) + (should (bolp)) + (should (= (point) (point-min))))) + +(ert-deftest test-music-pin-point-noop-at-bol () + "Normal: point already at the row start stays put." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-line 1) + (let ((before (point))) + (cj/music--pin-point-to-bol) + (should (= (point) before))))) + +;;; Boundary Cases + +(ert-deftest test-music-pin-point-skips-during-isearch () + "Boundary: an active isearch owns point; the pin defers until it ends." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-char 5) + (let ((isearch-mode t)) + (cj/music--pin-point-to-bol)) + (should-not (bolp)))) + +(ert-deftest test-music-pin-point-empty-buffer-no-error () + "Boundary: an empty buffer is a no-op, no error." + (with-temp-buffer + (should-not (cj/music--pin-point-to-bol)) + (should (bolp)))) + +;;; Hook wiring + +(ert-deftest test-music-pin-point-ensure-wires-post-command-hook () + "Normal: the playlist buffer gets the pin on its buffer-local +post-command-hook." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--pin-point-to-bol post-command-hook)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--pin-point) +;;; test-music-config--pin-point.el ends here diff --git a/tests/test-music-config--playlist-dock.el b/tests/test-music-config--playlist-dock.el index 69d24cc3..1dbe9fbb 100644 --- a/tests/test-music-config--playlist-dock.el +++ b/tests/test-music-config--playlist-dock.el @@ -70,5 +70,45 @@ silently does nothing." (should-not (boundp 'cj/--music-playlist-width)) (should-not (fboundp 'cj/--music-playlist-side))) +(ert-deftest test-music-config-playlist-default-height-is-half () + "Normal: the dock opens at half the frame height by default (Craig, +2026-07-18 -- a third still read too short for a real playlist)." + (should (= cj/music-playlist-window-height 0.5))) + +(ert-deftest test-music-config-playlist-toggle-off-discards-shrunk-height () + "Error: a captured height below the default is discarded. Window churn +squeezes the dock, and remembering the squeeze reopens it too short on +every later toggle." + (let ((buffer (generate-new-buffer " *test-playlist-shrink*")) + (cj/--music-playlist-height nil)) + (unwind-protect + (save-window-excursion + (set-window-buffer (selected-window) buffer) + (let ((cj/music-playlist-buffer-name (buffer-name buffer))) + (cl-letf (((symbol-function 'cj/side-window-capture-size) + (lambda (_w _side var) (set var 0.2))) + ((symbol-function 'delete-window) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/music-playlist-toggle))) + (should (null cj/--music-playlist-height))) + (kill-buffer buffer)))) + +(ert-deftest test-music-config-playlist-toggle-off-keeps-enlarged-height () + "Normal: a captured height at or above the default is remembered, so a +deliberate enlargement sticks for the session." + (let ((buffer (generate-new-buffer " *test-playlist-grow*")) + (cj/--music-playlist-height nil)) + (unwind-protect + (save-window-excursion + (set-window-buffer (selected-window) buffer) + (let ((cj/music-playlist-buffer-name (buffer-name buffer))) + (cl-letf (((symbol-function 'cj/side-window-capture-size) + (lambda (_w _side var) (set var 0.5))) + ((symbol-function 'delete-window) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/music-playlist-toggle))) + (should (= 0.5 cj/--music-playlist-height))) + (kill-buffer buffer)))) + (provide 'test-music-config--playlist-dock) ;;; test-music-config--playlist-dock.el ends here diff --git a/tests/test-music-config--playlist-open-position.el b/tests/test-music-config--playlist-open-position.el new file mode 100644 index 00000000..cd83e65b --- /dev/null +++ b/tests/test-music-config--playlist-open-position.el @@ -0,0 +1,147 @@ +;;; test-music-config--playlist-open-position.el --- Tests for playlist landing position -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Opening the playlist lands point by one rule: the beginning of the playing +;; track's line when a song is playing, else the top of the list. The old +;; behavior keyed off EMMS's selected track, which stays set while stopped, so +;; the playlist opened deep in the list at a stale position. The decision is +;; a pure helper; the window landing (point + upper-third recenter) is tested +;; with recenter stubbed at the display boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +;; Declare the emms vars special HERE too: the module's bare (defvar +;; emms-player-playing-p) marks them special only for code compiled in +;; that file, so a plain `let' in this lexical-binding test file would +;; bind them lexically and the module would never see the value (the +;; scope-shadowing trap from the testing rules). +(defvar emms-player-playing-p) +(defvar emms-playlist-selected-marker) + +(require 'music-config) + +(defmacro test-music-open-pos--with-buffer (var &rest body) + "Run BODY with VAR bound to a temp 3-track playlist-shaped buffer." + (declare (indent 1)) + `(let ((,var (generate-new-buffer " *test-open-pos*"))) + (unwind-protect + (progn + (with-current-buffer ,var + (insert "track one\ntrack two\ntrack three\n")) + ,@body) + (when (buffer-live-p ,var) (kill-buffer ,var))))) + +(defun test-music-open-pos--marker (buffer line offset) + "Marker in BUFFER at LINE (1-based) plus OFFSET chars." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (forward-char offset) + (point-marker)))) + +;;; Normal Cases + +(ert-deftest test-music-playlist-open-position-playing-lands-on-playing-line-start () + "Normal: playing -> the playing track's line, at its beginning (even when +the marker sits mid-line)." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 2 4))) + (should (= (cj/music--playlist-open-position buf) + (with-current-buffer buf + (save-excursion (goto-char (point-min)) (forward-line 1) (point)))))))) + +(ert-deftest test-music-playlist-open-position-stopped-lands-at-top () + "Normal: not playing -> top of the list, even though EMMS still has a +stale selected track." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 3 0))) + (should (= (cj/music--playlist-open-position buf) 1))))) + +;;; Boundary Cases + +(ert-deftest test-music-playlist-open-position-playing-no-marker-lands-at-top () + "Boundary: playing but no usable marker -> top of the list." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker nil)) + (should (= (cj/music--playlist-open-position buf) 1))))) + +(ert-deftest test-music-playlist-open-position-marker-in-other-buffer-lands-at-top () + "Boundary: a marker pointing into a different buffer is ignored." + (test-music-open-pos--with-buffer buf + (with-temp-buffer + (insert "elsewhere\n") + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (point-marker))) + (should (= (cj/music--playlist-open-position buf) 1)))))) + +(ert-deftest test-music-playlist-open-position-empty-buffer () + "Boundary: an empty playlist lands at point-min without error." + (let ((buf (generate-new-buffer " *test-open-pos-empty*"))) + (unwind-protect + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker nil)) + (should (= (cj/music--playlist-open-position buf) 1))) + (kill-buffer buf)))) + +;;; Landing (window boundary stubbed) + +(ert-deftest test-music-playlist-land-point-playing-recenter-upper-third () + "Normal: landing on a playing row sets window point to its line start and +recenters into the upper third." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 2 4)) + (recenter-arg 'not-called)) + (save-window-excursion + (set-window-buffer (selected-window) buf) + (cl-letf (((symbol-function 'recenter) + (lambda (&optional arg &rest _) (setq recenter-arg arg)))) + (cj/music--playlist-land-point (selected-window) buf)) + (should (= (window-point (selected-window)) + (with-current-buffer buf + (save-excursion (goto-char (point-min)) (forward-line 1) (point))))) + (should (integerp recenter-arg)) + (should (>= recenter-arg 1)))))) + +(ert-deftest test-music-playlist-land-point-stopped-top-no-recenter () + "Normal: landing while stopped puts window point at the top; no recenter." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker nil) + (recenter-called nil)) + (save-window-excursion + (set-window-buffer (selected-window) buf) + (cl-letf (((symbol-function 'recenter) + (lambda (&rest _) (setq recenter-called t)))) + (cj/music--playlist-land-point (selected-window) buf)) + (should (= (window-point (selected-window)) 1)) + (should-not recenter-called))))) + +;;; hl-line in the playlist buffer + +(ert-deftest test-music-playlist-ensure-enables-hl-line () + "Normal: the playlist buffer gets hl-line-mode so the current row is +findable even when the cursor sits on album art." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should hl-line-mode))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--playlist-open-position) +;;; test-music-config--playlist-open-position.el ends here diff --git a/tests/test-music-config--radio-tags.el b/tests/test-music-config--radio-tags.el new file mode 100644 index 00000000..60e1c9d8 --- /dev/null +++ b/tests/test-music-config--radio-tags.el @@ -0,0 +1,79 @@ +;;; test-music-config--radio-tags.el --- Tests for radio-browser tag pre-population -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The tag-search prompt completes over the popular tags fetched from +;; radio-browser's /json/tags endpoint (cached per session). These tests cover +;; the pure pieces: the endpoint URL, the parse (trim + drop-empty + dedupe, +;; since the source data is user-generated and dirty), and the session cache. +;; The network GET is mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defconst test-music-radio-tags--fixture + (concat "[{\"name\":\"jazz \",\"stationcount\":300}," + "{\"name\":\" jazz\",\"stationcount\":5}," + "{\"name\":\"\",\"stationcount\":2}," + "{\"name\":\"rock\",\"stationcount\":100}]") + "A recorded /json/tags response with whitespace, empty, and duplicate names.") + +;;; Normal Cases + +(ert-deftest test-music-radio-tags-url-shape () + "Normal: the tags URL targets /json/tags ordered by station count with the limit." + (let* ((cj/music-radio-tag-limit 500) + (u (cj/music-radio--tags-url "de1.api.radio-browser.info"))) + (should (string-match-p "/json/tags" u)) + (should (string-match-p "order=stationcount" u)) + (should (string-match-p "limit=500" u)))) + +(ert-deftest test-music-radio-parse-tags-trims-dedupes-drops-empty () + "Normal: tag names come back trimmed, deduped, and without empties." + (should (equal (cj/music-radio--parse-tags test-music-radio-tags--fixture) + '("jazz" "rock")))) + +(ert-deftest test-music-radio-available-tags-caches-per-session () + "Normal: the fetch runs once; later calls serve the cache." + (let ((cj/music-radio--tags-cache nil) + (calls 0)) + (cl-letf (((symbol-function 'cj/music-radio--http-get) + (lambda (_url) (cl-incf calls) test-music-radio-tags--fixture))) + (should (equal (cj/music-radio--available-tags) '("jazz" "rock"))) + (should (equal (cj/music-radio--available-tags) '("jazz" "rock"))) + (should (= calls 1))))) + +;;; Boundary Cases + +(ert-deftest test-music-radio-parse-tags-empty-array () + "Boundary: an empty tag array parses to nil." + (should-not (cj/music-radio--parse-tags "[]"))) + +;;; Error Cases + +(ert-deftest test-music-radio-available-tags-fetch-failure-returns-nil-and-retries () + "Error: a failed fetch yields nil, leaves the cache empty, and retries next call." + (let ((cj/music-radio--tags-cache nil) + (calls 0)) + (cl-letf (((symbol-function 'cj/music-radio--http-get) + (lambda (_url) (cl-incf calls) nil))) + (should-not (cj/music-radio--available-tags)) + (should-not cj/music-radio--tags-cache) + (should-not (cj/music-radio--available-tags)) + (should (= calls 2))))) + +(ert-deftest test-music-radio-parse-tags-malformed-user-errors () + "Error: a non-JSON body signals user-error, not a raw parse error." + (should-error (cj/music-radio--parse-tags "<html>502</html>") + :type 'user-error)) + +(provide 'test-music-config--radio-tags) +;;; test-music-config--radio-tags.el ends here diff --git a/tests/test-music-config--radio.el b/tests/test-music-config--radio.el index 3923a599..a91612bf 100644 --- a/tests/test-music-config--radio.el +++ b/tests/test-music-config--radio.el @@ -19,6 +19,10 @@ (defvar cj/custom-keymap (make-sparse-keymap) "Stub keymap for testing.") +;; Declare special here too (the module's bare defvar is file-local) so the +;; registration test's `let' binds dynamically. +(defvar marginalia-annotator-registry) + (require 'music-config) (declare-function cj/music-radio--parse-search "music-config" (json-text)) @@ -134,5 +138,70 @@ (should (= (length cands) 2)) (should (= (length (delete-dups (copy-sequence keys))) 2)))) +;;; --------------------------- query whitespace -------------------------------- + +(ert-deftest test-music-radio-search-and-play-trims-query () + "Normal: surrounding whitespace on the query is stripped before the search. +A trailing space in the minibuffer otherwise reaches the API as %20 and +matches nothing." + (let (captured) + (cl-letf (((symbol-function 'cj/emms--setup) #'ignore) + ((symbol-function 'cj/music-radio--search) + (lambda (query _field) (setq captured query) nil))) + (should-error (cj/music-radio--search-and-play " jazz " "tag") + :type 'user-error)) + (should (equal captured "jazz")))) + +(ert-deftest test-music-radio-search-and-play-whitespace-only-no-search () + "Error: a whitespace-only query errors out before any network search." + (let (searched) + (cl-letf (((symbol-function 'cj/emms--setup) #'ignore) + ((symbol-function 'cj/music-radio--search) + (lambda (&rest _) (setq searched t) nil))) + (should-error (cj/music-radio--search-and-play " " "tag") + :type 'user-error)) + (should-not searched))) + +;;; --------------------------- column alignment -------------------------------- + +(ert-deftest test-music-radio-format-candidate-votes-column-fixed-width () + "Normal: the votes field pads to a fixed width so the tags column aligns +across stations with different vote counts." + (let* ((low (cj/music-radio--format-candidate + '(:codec "MP3" :bitrate 128 :countrycode "US" :votes 7 :tags "jazz"))) + (high (cj/music-radio--format-candidate + '(:codec "MP3" :bitrate 128 :countrycode "US" :votes 174208 :tags "jazz")))) + (should (= (string-match "jazz" low) (string-match "jazz" high))))) + +(ert-deftest test-music-radio-completion-table-annotates-station () + "Normal: the table's annotation function returns the Variant-B string for +a station candidate (marginalia handles the right-alignment)." + (let* ((candidates '(("Jazz FM" . (:codec "MP3" :bitrate 128 :countrycode "US" + :votes 5 :tags "jazz")))) + (table (cj/music-radio--completion-table candidates)) + (meta (funcall table "" nil 'metadata)) + (annotate (alist-get 'annotation-function (cdr meta)))) + (should (functionp annotate)) + (should-not (alist-get 'affixation-function (cdr meta))) + (should (string-match-p "MP3" (funcall annotate "Jazz FM"))) + (should (string-match-p "jazz" (funcall annotate "Jazz FM"))))) + +(ert-deftest test-music-radio-completion-table-done-sentinel-no-annotation () + "Boundary: the [done] sentinel has no station and annotates as nil." + (let* ((candidates '(("[done]") ("Station" . (:codec "MP3" :bitrate 128 + :countrycode "US" :votes 1 :tags "x")))) + (table (cj/music-radio--completion-table candidates)) + (annotate (alist-get 'annotation-function + (cdr (funcall table "" nil 'metadata))))) + (should-not (funcall annotate "[done]")))) + +(ert-deftest test-music-radio-completion-table-registers-with-marginalia () + "Normal: building the table registers cj-radio-station so marginalia +right-aligns the table's own annotations." + (let ((marginalia-annotator-registry '())) + (cj/music-radio--completion-table '(("X" . (:codec "MP3")))) + (should (equal (assq 'cj-radio-station marginalia-annotator-registry) + '(cj-radio-station builtin none))))) + (provide 'test-music-config--radio) ;;; test-music-config--radio.el ends here diff --git a/tests/test-music-config--renumber-rows.el b/tests/test-music-config--renumber-rows.el new file mode 100644 index 00000000..d5bc5141 --- /dev/null +++ b/tests/test-music-config--renumber-rows.el @@ -0,0 +1,232 @@ +;;; test-music-config--renumber-rows.el --- Tests for playlist row numbering -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Playlist rows carry a numeric overlay prefix so the cursor stays visible +;; when it sits on a cover-art thumbnail and each row's position in the list +;; is readable. The renumber walks the buffer and rebuilds the overlays; a +;; buffer-local after-change hook debounces it behind an idle timer. Overlays +;; leave the buffer text untouched (EMMS owns it), so these tests drive plain +;; temp buffers. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defun test-music-renumber--numbers (buffer) + "Return the overlay number strings in BUFFER, in position order." + (with-current-buffer buffer + (mapcar (lambda (ov) (overlay-get ov 'before-string)) + (sort (seq-filter (lambda (ov) (overlay-get ov 'cj-music-row-number)) + (overlays-in (point-min) (point-max))) + (lambda (a b) (< (overlay-start a) (overlay-start b))))))) + +;;; Normal Cases + +(ert-deftest test-music-renumber-rows-numbers-each-line () + "Normal: every non-blank line gets a sequential number overlay." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\n") + (cj/music--renumber-rows (current-buffer)) + (should (equal (mapcar #'substring-no-properties + (test-music-renumber--numbers (current-buffer))) + '(" 1 " " 2 " " 3 "))))) + +(ert-deftest test-music-renumber-rows-idempotent () + "Normal: renumbering twice leaves one overlay per line, not two." + (with-temp-buffer + (insert "track one\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (cj/music--renumber-rows (current-buffer)) + (should (= 2 (length (test-music-renumber--numbers (current-buffer))))))) + +(ert-deftest test-music-renumber-rows-number-carries-cursor-property () + "Normal: the number string carries a cursor property. Point is pinned at +the row start, and without the property redisplay draws the cursor after +the before-string -- on the album-art thumbnail, where it's invisible." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (let ((s (car (test-music-renumber--numbers (current-buffer))))) + (should (get-text-property 0 'cursor s))))) + +;;; Boundary Cases + +(ert-deftest test-music-renumber-rows-skips-blank-lines () + "Boundary: blank lines are not numbered and don't advance the count." + (with-temp-buffer + (insert "track one\n\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (should (equal (mapcar #'substring-no-properties + (test-music-renumber--numbers (current-buffer))) + '(" 1 " " 2 "))))) + +(ert-deftest test-music-renumber-rows-empty-buffer-no-overlays () + "Boundary: an empty buffer gets no overlays and no error." + (with-temp-buffer + (cj/music--renumber-rows (current-buffer)) + (should-not (test-music-renumber--numbers (current-buffer))))) + +;;; Error Cases + +(ert-deftest test-music-renumber-rows-dead-buffer-noop () + "Error: renumbering a killed buffer is a silent no-op (the debounce timer +can fire after the playlist buffer is gone)." + (let ((buf (generate-new-buffer " *test-renumber-dead*"))) + (kill-buffer buf) + (should-not (cj/music--renumber-rows buf)))) + +(ert-deftest test-music-renumber-rows-number-outranks-header-overlay () + "Normal: number overlays carry a priority above the header overlay's 100. +The header block is a same-position overlay string at the buffer start; +without the higher priority, row 1's number renders above the header +instead of next to its own track." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (let ((ov (car (seq-filter (lambda (o) (overlay-get o 'cj-music-row-number)) + (overlays-in (point-min) (point-max)))))) + (should (> (or (overlay-get ov 'priority) 0) 100))))) + +(ert-deftest test-music-ensure-playlist-buffer-logical-line-motion () + "Normal: the playlist moves by logical lines, not screen lines. The +multi-line header overlay string at position 1 otherwise absorbs every +next-line from the top row -- vertical motion steps through the header's +display and maps back to the same buffer position, so arrows look dead." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (local-variable-p 'line-move-visual)) + (should-not line-move-visual))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Current-row indicator + +(ert-deftest test-music-highlight-current-number-marks-current-row () + "Normal: the current row's number renders inverse-video; moving to another +row restores the old one and marks the new one. The block cursor only +draws in the selected window, so the number itself carries the mark." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (forward-line 1) + (cj/music--highlight-current-number) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should-not (plist-get (get-text-property 0 'face (nth 0 numbers)) :inverse-video)) + (should (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video))) + (forward-line 1) + (cj/music--highlight-current-number) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should-not (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video)) + (should (plist-get (get-text-property 0 'face (nth 2 numbers)) :inverse-video))))) + +(ert-deftest test-music-highlight-current-number-survives-renumber () + "Boundary: a renumber rebuilds the overlays; the highlight re-applies to +the current row rather than pointing at a dead overlay." + (with-temp-buffer + (insert "track one\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (forward-line 1) + (cj/music--highlight-current-number) + (cj/music--renumber-rows (current-buffer)) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video))))) + +(ert-deftest test-music-highlight-current-number-keeps-cursor-property () + "Boundary: re-facing a number keeps the cursor property intact." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (cj/music--highlight-current-number) + (let ((s (car (test-music-renumber--numbers (current-buffer))))) + (should (get-text-property 0 'cursor s))))) + +(ert-deftest test-music-ensure-playlist-buffer-sticky-hl-line () + "Normal: hl-line in the playlist stays visible when the window isn't +selected -- the dock is glanced at from other windows constantly." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (should (buffer-local-value 'hl-line-sticky-flag created))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Sticky header + +(ert-deftest test-music-stick-header-moves-overlay-to-window-start () + "Normal: a scroll re-anchors the header overlay at the new window start, +so the header block stays at the top of the window while the list scrolls." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\ntrack four\n") + (setq cj/music--header-overlay (make-overlay (point-min) (point-min))) + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (let ((start (save-excursion (goto-char (point-min)) (forward-line 2) (point)))) + (cj/music--stick-header (selected-window) start) + (should (= (overlay-start cj/music--header-overlay) start)) + ;; Converges: the same start again is a no-op, not a loop. + (cj/music--stick-header (selected-window) start) + (should (= (overlay-start cj/music--header-overlay) start)))))) + +(ert-deftest test-music-stick-header-no-overlay-noop () + "Boundary: no header overlay yet -- the scroll handler is a silent no-op." + (with-temp-buffer + (insert "track one\n") + (setq cj/music--header-overlay nil) + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (should-not (cj/music--stick-header (selected-window) (point-min)))))) + +(ert-deftest test-music-header-anchor-position-displayed-vs-not () + "Normal: the header anchors at the displaying window's start; an +undisplayed buffer anchors at the top." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\ntrack four\n") + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (let ((start (save-excursion (goto-char (point-min)) (forward-line 2) (point)))) + (set-window-start (selected-window) start) + (should (= (cj/music--header-anchor-position) start)))) + ;; Not displayed after the excursion restores the old config. + (should (= (cj/music--header-anchor-position) (point-min))))) + +(ert-deftest test-music-ensure-playlist-buffer-wires-scroll-hook () + "Normal: the playlist buffer re-sticks its header on every window scroll." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--stick-header window-scroll-functions)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Hook wiring + +(ert-deftest test-music-renumber-ensure-playlist-buffer-wires-hook () + "Normal: the playlist buffer gets the debounced renumber on after-change." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--schedule-renumber after-change-functions)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--renumber-rows) +;;; test-music-config--renumber-rows.el ends here diff --git a/tests/test-music-config-commands.el b/tests/test-music-config-commands.el index 3c585d0b..40fb2d81 100644 --- a/tests/test-music-config-commands.el +++ b/tests/test-music-config-commands.el @@ -30,17 +30,21 @@ ;;; cj/music-add-directory-recursive (ert-deftest test-music-add-directory-recursive-passes-dir-to-emms () - "Normal: add-directory-recursive routes through emms-add-directory-tree." + "Normal: add-directory-recursive feeds the directory's music files (and +only those) to emms-add-file -- the raw-tree path added cover art too." (let* ((tmp (file-name-as-directory (make-temp-file "cj-music-add-" t))) - called) + added) (unwind-protect - (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) #'ignore) - ((symbol-function 'emms-add-directory-tree) - (lambda (dir) (setq called dir))) - ((symbol-function 'message) #'ignore)) - (cj/music-add-directory-recursive tmp)) + (progn + (write-region "" nil (expand-file-name "song.mp3" tmp)) + (write-region "" nil (expand-file-name "cover.jpg" tmp)) + (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) #'ignore) + ((symbol-function 'emms-add-file) + (lambda (f) (push f added))) + ((symbol-function 'message) #'ignore)) + (cj/music-add-directory-recursive tmp))) (delete-directory tmp t)) - (should (equal called tmp)))) + (should (equal (mapcar #'file-name-nondirectory added) '("song.mp3"))))) (ert-deftest test-music-add-directory-recursive-errors-on-non-directory () "Error: passing a regular file (not a directory) signals user-error." diff --git a/tests/test-music-config-create-radio-station.el b/tests/test-music-config-create-radio-station.el index 7d9adbed..4f49f49b 100644 --- a/tests/test-music-config-create-radio-station.el +++ b/tests/test-music-config-create-radio-station.el @@ -106,15 +106,16 @@ (ert-deftest test-music-config-menu-map-lowercase-keys () "Normal: the menu's former uppercase keys live on lowercase homes, and the -playlist buffer saves on v." +playlist buffer saves on s (single on 1, old save key v unbound)." (should (eq (lookup-key cj/music-map "v") 'cj/music-playlist-show)) (should (eq (lookup-key cj/music-map "u") 'emms-shuffle)) (should (eq (lookup-key cj/music-map "l") 'emms-toggle-repeat-playlist)) (should-not (lookup-key cj/music-map "R")) (should-not (lookup-key cj/music-map "M")) (should-not (lookup-key cj/music-map "Z")) - (should (eq (lookup-key emms-playlist-mode-map "v") 'cj/music-playlist-save)) - (should-not (eq (lookup-key emms-playlist-mode-map "w") 'cj/music-playlist-save))) + (should (eq (lookup-key emms-playlist-mode-map "s") 'cj/music-playlist-save)) + (should (eq (lookup-key emms-playlist-mode-map "1") 'emms-toggle-repeat-track)) + (should-not (lookup-key emms-playlist-mode-map "v"))) ;;; Error Cases diff --git a/tests/test-music-config-helpers-untested.el b/tests/test-music-config-helpers-untested.el index bfdb2634..87aa210c 100644 --- a/tests/test-music-config-helpers-untested.el +++ b/tests/test-music-config-helpers-untested.el @@ -154,17 +154,18 @@ test prelude inserts filler with `inhibit-read-only' bound." ;;; ---------- cj/music-add-directory-recursive ---------- (ert-deftest test-mc-add-directory-recursive-normal-calls-emms () - "Normal: with an existing directory, the recursive add reaches emms." + "Normal: with an existing directory, the recursive add reaches emms with +each music file individually (the filtered walk, not the raw tree)." (test-mc-untested--setup) (unwind-protect (let* ((dir cj/test-base-dir) - (called-with nil)) - (cl-letf (((symbol-function 'emms-add-directory-tree) - (lambda (d) (setq called-with d))) + (added nil)) + (write-region "" nil (expand-file-name "one.mp3" dir)) + (cl-letf (((symbol-function 'emms-add-file) + (lambda (f) (push f added))) ((symbol-function 'message) #'ignore)) (cj/music-add-directory-recursive dir)) - (should (equal (file-name-as-directory called-with) - (file-name-as-directory dir)))) + (should (member "one.mp3" (mapcar #'file-name-nondirectory added)))) (test-mc-untested--teardown))) (ert-deftest test-mc-add-directory-recursive-error-not-a-directory () diff --git a/tests/test-nov-reading--config-defaults.el b/tests/test-nov-reading--config-defaults.el index 5e454ce1..ff52d8f5 100644 --- a/tests/test-nov-reading--config-defaults.el +++ b/tests/test-nov-reading--config-defaults.el @@ -16,6 +16,8 @@ (declare-function cj/nov--next-reading-palette "nov-reading" (current names)) (defvar cj/nov-reading-palettes) (defvar cj/nov-reading-default-palette) +(defvar cj/nov-reading-profile) +(defvar cj/nov--typography-remap-cookies) (ert-deftest test-nov-reading-config-default-is-dark () "Normal: a fresh nov buffer opens on the dark palette." @@ -34,5 +36,32 @@ (should-not (cj/nov--next-reading-palette "light" names)) (should (equal (cj/nov--next-reading-palette nil names) "dark")))) +(ert-deftest test-nov-reading-config-uses-reading-font-profile () + "Normal: nov typography names the shared Reading profile." + (should (eq cj/nov-reading-profile 'reading))) + +(ert-deftest test-nov-reading-depends-on-pure-profile-layer () + "Boundary: loading nov shares profile data without loading Fontaine config." + (should (featurep 'font-profiles)) + (should-not (featurep 'font-config))) + +(ert-deftest test-nov-reading-typography-remaps-shared-profile-locally () + "Normal: nov applies Reading locally at its own base height without stacking." + (let ((cj/nov--typography-remap-cookies '(old-default old-fixed)) + (removed nil) + (applied nil)) + (cl-letf (((symbol-function 'face-remap-remove-relative) + (lambda (cookie) (push cookie removed))) + ((symbol-function 'cj/font-profile-remap-buffer) + (lambda (profile height) + (setq applied (list profile height)) + '(new-default new-fixed)))) + (cj/nov-reading-apply-typography)) + (should (equal applied '(reading 180))) + (should (equal (sort removed #'string-lessp) + '(old-default old-fixed))) + (should (equal cj/nov--typography-remap-cookies + '(new-default new-fixed))))) + (provide 'test-nov-reading--config-defaults) ;;; test-nov-reading--config-defaults.el ends here diff --git a/tests/test-org-agenda-config--auto-refresh.el b/tests/test-org-agenda-config--auto-refresh.el new file mode 100644 index 00000000..58ef729b --- /dev/null +++ b/tests/test-org-agenda-config--auto-refresh.el @@ -0,0 +1,170 @@ +;;; test-org-agenda-config--auto-refresh.el --- Tests for agenda auto-refresh -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the wall-clock-aligned auto-refresh behind the F8 agenda: +;; the next-mark arithmetic, the on-screen-agenda lookup, the timer body's +;; error containment, and start/stop timer ownership. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-agenda-config) + +;; -- Fixtures ---------------------------------------------------------------- + +(defun test-org-agenda-auto-refresh--time (hh mm ss) + "Return an Emacs time value for today at HH:MM:SS local time." + (let ((now (decode-time))) + (encode-time (list ss mm hh + (nth 3 now) (nth 4 now) (nth 5 now) + nil -1 (nth 8 now))))) + +(defmacro test-org-agenda-auto-refresh--with-agenda-window (&rest body) + "Run BODY with a window displaying a buffer in `org-agenda-mode'. +Sets `major-mode' directly rather than calling the mode function: the +lookup under test only asks what mode the window's buffer is in, and +`org-agenda-mode' setup wants a real agenda build behind it." + (declare (indent 0)) + `(let ((buffer (get-buffer-create "*Org Agenda*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer buffer + (setq major-mode 'org-agenda-mode)) + (set-window-buffer (selected-window) buffer) + ,@body) + (kill-buffer buffer)))) + +;; -- cj/--org-agenda-seconds-to-next-mark ------------------------------------ + +(ert-deftest test-org-agenda-config-next-mark-mid-interval () + "Normal: a time between marks returns the remainder to the next one." + (should (= 120 (cj/--org-agenda-seconds-to-next-mark + (test-org-agenda-auto-refresh--time 9 3 0) 300)))) + +(ert-deftest test-org-agenda-config-next-mark-exactly-on-mark () + "Boundary: a time exactly on a mark returns a full period, never zero. +A zero delay would fire the timer immediately and again a period later." + (should (= 300 (cj/--org-agenda-seconds-to-next-mark + (test-org-agenda-auto-refresh--time 9 5 0) 300)))) + +(ert-deftest test-org-agenda-config-next-mark-one-second-before () + "Boundary: one second short of a mark returns one second." + (should (= 1 (cj/--org-agenda-seconds-to-next-mark + (test-org-agenda-auto-refresh--time 9 4 59) 300)))) + +(ert-deftest test-org-agenda-config-next-mark-lands-on-a-multiple () + "Normal: TIME plus the result is always a whole multiple of PERIOD. +This is the property that makes the refresh land on :00/:05 rather than +five minutes after whenever the agenda happened to open." + (dolist (seconds '(0 1 59 60 61 149 150 299)) + (let* ((time (test-org-agenda-auto-refresh--time 9 0 0)) + (start (+ (floor (float-time time)) seconds)) + (delay (cj/--org-agenda-seconds-to-next-mark start 300))) + (should (zerop (mod (+ start delay) 300)))))) + +(ert-deftest test-org-agenda-config-next-mark-rejects-nonpositive-period () + "Error: a zero or negative period is a caller bug, not a silent no-op." + (should-error (cj/--org-agenda-seconds-to-next-mark (current-time) 0)) + (should-error (cj/--org-agenda-seconds-to-next-mark (current-time) -300))) + +;; -- cj/--org-agenda-refresh-window ------------------------------------------ + +(ert-deftest test-org-agenda-config-refresh-window-finds-displayed-agenda () + "Normal: the lookup returns the window showing an agenda buffer." + (test-org-agenda-auto-refresh--with-agenda-window + (should (eq (cj/--org-agenda-refresh-window) (selected-window))))) + +(ert-deftest test-org-agenda-config-refresh-window-nil-when-not-displayed () + "Boundary: an agenda buffer that exists but is off-screen is not a target. +Rebuilding an invisible agenda costs time and shows nobody anything." + (let ((buffer (get-buffer-create "*Org Agenda*"))) + (unwind-protect + (progn + (with-current-buffer buffer (setq major-mode 'org-agenda-mode)) + (should-not (cj/--org-agenda-refresh-window))) + (kill-buffer buffer)))) + +(ert-deftest test-org-agenda-config-refresh-window-nil-with-no-agenda () + "Boundary: no agenda buffer anywhere returns nil rather than erroring." + (should-not (cj/--org-agenda-refresh-window))) + +;; -- cj/--org-agenda-auto-refresh (the timer body) --------------------------- + +(ert-deftest test-org-agenda-config-auto-refresh-noop-without-agenda () + "Boundary: the tick does nothing, and signals nothing, with no agenda up." + (let ((called nil)) + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) (setq called t)))) + (cj/--org-agenda-auto-refresh) + (should-not called)))) + +(ert-deftest test-org-agenda-config-auto-refresh-redoes-visible-agenda () + "Normal: the tick redoes the agenda shown on screen." + (let ((called nil)) + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) (setq called t)))) + (test-org-agenda-auto-refresh--with-agenda-window + (cj/--org-agenda-auto-refresh)) + (should called)))) + +(ert-deftest test-org-agenda-config-auto-refresh-contains-errors () + "Error: a failing redo must not escape the timer body. +An unguarded signal in a repeating timer resignals on every tick, which is +how a five-minute timer turns into an endless backtrace." + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) (error "simulated redo failure"))) + ((symbol-function 'cj/log-silently) (lambda (&rest _) nil))) + (test-org-agenda-auto-refresh--with-agenda-window + (should (progn (cj/--org-agenda-auto-refresh) t))))) + +(ert-deftest test-org-agenda-config-auto-refresh-restores-point-line () + "Normal: the tick leaves point on the line it started on. +A refresh that scrolls the reader back to the top every five minutes is +worse than no refresh." + (cl-letf (((symbol-function 'org-agenda-redo) (lambda (&rest _) nil))) + (test-org-agenda-auto-refresh--with-agenda-window + (with-current-buffer "*Org Agenda*" + (erase-buffer) + (dotimes (i 10) (insert (format "agenda line %d\n" i))) + (goto-char (point-min)) + (forward-line 4)) + (cj/--org-agenda-auto-refresh) + (with-current-buffer "*Org Agenda*" + (should (= 5 (line-number-at-pos))))))) + +;; -- start / stop ------------------------------------------------------------ + +(ert-deftest test-org-agenda-config-auto-refresh-start-owns-one-timer () + "Normal: starting twice leaves exactly one timer, not two. +Re-loading the module in a live daemon re-runs the arming form, so a +non-idempotent start would stack a second ticker on every reload." + (let ((cj/--org-agenda-refresh-timer nil)) + (unwind-protect + (progn + (cj/org-agenda-auto-refresh-start) + (let ((first cj/--org-agenda-refresh-timer)) + (cj/org-agenda-auto-refresh-start) + (should (timerp cj/--org-agenda-refresh-timer)) + (should-not (memq first timer-list)) + (should (memq cj/--org-agenda-refresh-timer timer-list)))) + (cj/org-agenda-auto-refresh-stop)))) + +(ert-deftest test-org-agenda-config-auto-refresh-stop-clears-timer () + "Normal: stopping cancels the timer and clears the handle." + (let ((cj/--org-agenda-refresh-timer nil)) + (cj/org-agenda-auto-refresh-start) + (let ((timer cj/--org-agenda-refresh-timer)) + (cj/org-agenda-auto-refresh-stop) + (should-not cj/--org-agenda-refresh-timer) + (should-not (memq timer timer-list))))) + +(ert-deftest test-org-agenda-config-auto-refresh-stop-is-safe-when-stopped () + "Boundary: stopping an already-stopped refresh is a no-op, not an error." + (let ((cj/--org-agenda-refresh-timer nil)) + (should (progn (cj/org-agenda-auto-refresh-stop) t)) + (should-not cj/--org-agenda-refresh-timer))) + +(provide 'test-org-agenda-config--auto-refresh) +;;; test-org-agenda-config--auto-refresh.el ends here diff --git a/tests/test-org-agenda-config-category.el b/tests/test-org-agenda-config-category.el index 6a54d9e6..918d342a 100644 --- a/tests/test-org-agenda-config-category.el +++ b/tests/test-org-agenda-config-category.el @@ -88,12 +88,11 @@ Suppresses other org-mode hooks to keep the test isolated." (text-mode-hook nil)) (org-mode)) (setq buffer-file-name ,path) - ;; mimic org's default category (filename-sans-extension) so the - ;; hook's "only override the default" guard is exercised. - (setq-local org-category - (and ,path - (file-name-sans-extension - (file-name-nondirectory ,path)))) + ;; `org-category' is deliberately left nil, which is what org actually + ;; does with no `#+CATEGORY:'. An earlier version of this fixture set it + ;; to the filename base to "mimic org's default"; org never does that, so + ;; these tests passed against a state that cannot occur while the feature + ;; did nothing in practice. ,body-form)) ;;; Normal Cases @@ -106,11 +105,14 @@ Suppresses other org-mode hooks to keep the test isolated." (should (equal "emacs.d" org-category))))) (ert-deftest test-org-agenda-config-category-hook-normal-leaves-inbox-alone () - "Normal: hook leaves inbox.org's category at its filename default." + "Normal: hook declines on a non-todo file, leaving `org-category' unset. +Leaving it nil is the correct outcome, not a gap: `org-get-category' then +derives \"inbox\" from the filename, which is already a useful label. The +end-to-end test below checks that derivation on a real file." (test-org-agenda-config-category--with-file "/home/cjennings/sync/org/roam/inbox.org" (progn (cj/--org-set-todo-category) - (should (equal "inbox" org-category))))) + (should (null org-category))))) ;;; Boundary Cases @@ -133,5 +135,98 @@ Suppresses other org-mode hooks to keep the test isolated." ;; no error and no spurious mutation (should t))) +;;; ---------- End-to-end: a real file through the real hook ---------- +;; The fixture above sets `org-category' by hand to the filename base, to +;; "mimic org's default". Org does not do that: with no `#+CATEGORY:' it +;; leaves `org-category' nil and derives the fallback inside +;; `org-get-category' at read time. So those tests exercise a precondition +;; that never occurs, and passed while the feature did nothing in practice. +;; +;; These drive a real file on disk through `find-file-noselect' (which runs +;; `org-mode-hook' for real) and assert on `org-get-category', which is what +;; the agenda's %c column actually reads. + +(defmacro test-org-agenda-config-category--with-real-file (spec &rest body) + "Create FILE under a temp project dir and visit it, then run BODY. +SPEC is (VAR DIRNAME FILENAME CONTENT). VAR is bound to the live buffer." + (declare (indent 1)) + (let ((var (nth 0 spec)) (dirname (nth 1 spec)) + (filename (nth 2 spec)) (content (nth 3 spec))) + ;; The outer `unwind-protect' covers `find-file-noselect' itself, so a + ;; signal there still removes the temp tree rather than leaking it. + `(let* ((root (make-temp-file "cj-cat-" t)) + (project (expand-file-name ,dirname root)) + (path (expand-file-name ,filename project)) + (,var nil)) + (unwind-protect + (progn + (make-directory project t) + (with-temp-file path (insert ,content)) + (setq ,var (find-file-noselect path)) + ,@body) + (when (buffer-live-p ,var) + (with-current-buffer ,var (set-buffer-modified-p nil)) + (kill-buffer ,var)) + (delete-directory root t))))) + +(ert-deftest test-org-agenda-config-category-endtoend-todo-shows-project () + "Normal: visiting a project's todo.org makes the agenda show the project. +This is the whole point of the feature, and it is what the hand-built +fixture above could not check." + (test-org-agenda-config-category--with-real-file + (buffer "myproject" "todo.org" "* TODO a task\n") + (with-current-buffer buffer + (should (equal "myproject" (org-get-category (point-min))))))) + +(ert-deftest test-org-agenda-config-category-endtoend-explicit-category-wins () + "Boundary: an explicit `#+CATEGORY:' still beats the derived name. + +Note what this does and does not prove. It confirms the user-visible contract, +but not that the hook's guard is what enforces it: `org-element--get-category' +searches the buffer for `#+CATEGORY:' itself and returns that before consulting +`org-category', so the directive survives even with the guard deleted. The +guard's own job is covered by +`test-org-agenda-config-category-hook-boundary-respects-explicit'." + (test-org-agenda-config-category--with-real-file + (buffer "myproject" "todo.org" "#+CATEGORY: Personal\n* TODO a task\n") + (with-current-buffer buffer + (should (equal "Personal" (org-get-category (point-min))))))) + +(ert-deftest test-org-agenda-config-category-endtoend-survives-an-earlier-hook () + "Error: the override still lands when another hook reads the category first. + +`org-get-category' resolves a deferred `:CATEGORY' that the org-element cache +then holds. A hook running BEFORE ours that reads it freezes \"todo\" in that +cache, and our later `setq-local' becomes inert -- `org-category' reads correct +while the agenda still shows \"todo\". + +This is not hypothetical. `add-hook' prepends by default, so every hook added +after ours runs before it, and the live config already has three ahead of it. +The fix is the explicit depth on our `add-hook'; this test is what holds it +there." + (test-org-agenda-config-category--with-real-file + (buffer "projX" "todo.org" "* TODO a task\n") + (ignore buffer)) + ;; Re-visit with a nosy reader installed ahead of ours. + (let ((reader (lambda () (ignore (org-get-category (point-min)))))) + (unwind-protect + (progn + (add-hook 'org-mode-hook reader) + (test-org-agenda-config-category--with-real-file + (buffer "projX" "todo.org" "* TODO a task\n") + (with-current-buffer buffer + (should (equal "projX" (org-get-category (point-min))))))) + (remove-hook 'org-mode-hook reader)))) + +(ert-deftest test-org-agenda-config-category-endtoend-other-filename-untouched () + "Boundary: a distinctively-named file keeps its filename category. +Only todo.org is generic enough to be worth replacing. Files like +schedule.org or gcal.org already say something useful, and deriving from +the directory would collapse several of them onto one name." + (test-org-agenda-config-category--with-real-file + (buffer "data" "gcal.org" "* TODO an event\n") + (with-current-buffer buffer + (should (equal "gcal" (org-get-category (point-min))))))) + (provide 'test-org-agenda-config-category) ;;; test-org-agenda-config-category.el ends here diff --git a/tests/test-org-agenda-config-display.el b/tests/test-org-agenda-config-display.el index af4c7ea0..f039985d 100644 --- a/tests/test-org-agenda-config-display.el +++ b/tests/test-org-agenda-config-display.el @@ -2,6 +2,8 @@ ;;; Commentary: ;; Tests for the display-buffer rule used by the F8 org agenda view. +;; The agenda takes the whole frame; these pin that, and pin the two ways +;; it previously failed to (a fraction of the frame, or shrunk to fit). ;;; Code: @@ -10,39 +12,58 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'org-agenda-config) -(ert-deftest test-org-agenda-config-display-rule-uses-configured-height () - "Normal: the agenda display rule uses the configured frame fraction." - (let ((cj/org-agenda-window-height 0.75)) - (should (equal (cdr (assoc 'window-height - (cddr (cj/--org-agenda-display-rule)))) - 0.75)))) +(defun test-org-agenda-config-display--actions () + "Return the display-action function list from the agenda rule." + (car (cdr (cj/--org-agenda-display-rule)))) + +(defun test-org-agenda-config-display--alist () + "Return the action alist from the agenda rule." + (cddr (cj/--org-agenda-display-rule))) + +(ert-deftest test-org-agenda-config-display-rule-takes-full-frame () + "Normal: the agenda display rule claims the whole frame." + (should (memq 'display-buffer-full-frame + (test-org-agenda-config-display--actions)))) + +(ert-deftest test-org-agenda-config-display-rule-reuses-agenda-window () + "Normal: an agenda already on screen is reused rather than re-displayed." + (should (memq 'display-buffer-reuse-mode-window + (test-org-agenda-config-display--actions)))) + +(ert-deftest test-org-agenda-config-display-rule-sets-no-window-height () + "Regression: no height fraction survives. +The rule used to hand the agenda 0.75 of the frame; a leftover +`window-height' entry would cap the full-frame window right back down." + (should-not (assoc 'window-height (test-org-agenda-config-display--alist)))) (ert-deftest test-org-agenda-config-display-rule-does-not-fit-to-buffer () "Regression: F8 agenda should not shrink to fit compact agenda contents." - (let ((cj/org-agenda-window-height 0.75)) - (should-not (eq (cdr (assoc 'window-height - (cddr (cj/--org-agenda-display-rule)))) - 'fit-window-to-buffer)))) - -(ert-deftest test-org-agenda-config-display-rule-creates-large-window () - "Integration: the agenda rule creates a window near the configured height." - (let ((cj/org-agenda-window-height 0.75) - (display-buffer-alist (list (cj/--org-agenda-display-rule))) + (should-not (eq (cdr (assoc 'window-height + (test-org-agenda-config-display--alist))) + 'fit-window-to-buffer))) + +(ert-deftest test-org-agenda-config-display-rule-window-not-dedicated () + "Regression: the agenda window must not be dedicated. +With the agenda owning the only window, a dedicated one leaves RET on an +item (`org-agenda-switch-to') nowhere to put the file, so it splits or +opens a frame instead of replacing the agenda." + (should-not (cdr (assoc 'dedicated (test-org-agenda-config-display--alist))))) + +(ert-deftest test-org-agenda-config-display-rule-creates-sole-window () + "Integration: displaying the agenda leaves it as the frame's only window." + (let ((display-buffer-alist (list (cj/--org-agenda-display-rule))) (buffer (get-buffer-create "*Org Agenda*"))) (unwind-protect (save-window-excursion (delete-other-windows) + (split-window-below) (with-current-buffer buffer (erase-buffer) - (dotimes (_ 3) - (insert "agenda line\n"))) - (let* ((before-height (window-total-height)) - (window (display-buffer buffer)) - (actual-ratio (/ (float (window-total-height window)) - before-height))) - (should (= 2 (length (window-list)))) - (should (> actual-ratio 0.65)) - (should (< actual-ratio 0.85)))) + (dotimes (_ 3) (insert "agenda line\n"))) + (let ((window (display-buffer buffer))) + (should (= 1 (length (window-list)))) + (should (eq window (car (window-list)))) + (should (eq (window-buffer window) buffer)))) (kill-buffer buffer)))) (provide 'test-org-agenda-config-display) diff --git a/tests/test-org-refile-config--advice-helpers.el b/tests/test-org-refile-config--advice-helpers.el new file mode 100644 index 00000000..0d9979d8 --- /dev/null +++ b/tests/test-org-refile-config--advice-helpers.el @@ -0,0 +1,87 @@ +;;; test-org-refile-config--advice-helpers.el --- Tests for the refile advice helpers -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for the two named advice helpers extracted from anonymous lambdas +;; in the org-refile use-package :config block: +;; +;; cj/org-refile--save-all-buffers (:after org-refile) +;; cj/org-refile--ensure-targets-in-org-mode (:before org-refile-get-targets) +;; +;; They were anonymous `(lambda (&rest _) ...)' advices, which cannot be +;; `advice-remove'd by reference and cannot be tested. Naming them makes both +;; possible. The install-by-reference and removability are verified live in the +;; daemon (the :config block doesn't run under batch make test); these tests +;; pin the extracted logic. +;; +;; Test organization: +;; - Normal Cases: ensure-targets visits each string-named target +;; - Boundary Cases: empty targets, non-string cars, mixed list +;; - Error Cases: a nil target list is a no-op +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-refile-config) + +;; The module's bare `(defvar org-refile-targets)' marks the symbol special only +;; within its own file, so it isn't special here. Declare it (with a value) so +;; the `let' bindings below bind it dynamically, the way the sibling +;; test-org-refile-config-commands.el does. +(defvar org-refile-targets nil) + +;;; cj/org-refile--ensure-targets-in-org-mode + +(ert-deftest test-org-refile-ensure-targets-visits-each-string-target () + "Normal: every string-named target file is passed to the ensure helper." + (let ((org-refile-targets '(("/a.org" :maxlevel . 3) + ("/b.org" :maxlevel . 3))) + (seen '())) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) + (lambda (f) (push f seen)))) + (cj/org-refile--ensure-targets-in-org-mode)) + (should (equal '("/a.org" "/b.org") (nreverse seen))))) + +;;; Boundary + +(ert-deftest test-org-refile-ensure-targets-skips-non-string-cars () + "Boundary: a target whose car is not a string (a function/symbol spec) is +skipped rather than passed to the ensure helper." + (let ((org-refile-targets `((,(lambda () '("/x.org")) :maxlevel . 2) + ("/real.org" :maxlevel . 2) + (org-agenda-files :maxlevel . 2))) + (seen '())) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) + (lambda (f) (push f seen)))) + (cj/org-refile--ensure-targets-in-org-mode)) + (should (equal '("/real.org") seen)))) + +(ert-deftest test-org-refile-ensure-targets-empty-list-is-noop () + "Boundary: no targets means the ensure helper is never called." + (let ((org-refile-targets '()) + (called nil)) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) + (lambda (_f) (setq called t)))) + (cj/org-refile--ensure-targets-in-org-mode)) + (should-not called))) + +;;; Error + +(ert-deftest test-org-refile-ensure-targets-nil-targets-does-not-signal () + "Error: a nil `org-refile-targets' completes without signaling." + (let ((org-refile-targets nil)) + (cl-letf (((symbol-function 'cj/org-refile-ensure-org-mode) #'ignore)) + (should (progn (cj/org-refile--ensure-targets-in-org-mode) t))))) + +;;; cj/org-refile--save-all-buffers + +(ert-deftest test-org-refile-save-all-buffers-delegates () + "Normal: the save helper calls `org-save-all-org-buffers'." + (let ((called nil)) + (cl-letf (((symbol-function 'org-save-all-org-buffers) + (lambda (&rest _) (setq called t)))) + (cj/org-refile--save-all-buffers)) + (should called))) + +(provide 'test-org-refile-config--advice-helpers) +;;; test-org-refile-config--advice-helpers.el ends here diff --git a/tests/test-org-roam-config-format.el b/tests/test-org-roam-config-format.el index e9378b7a..16370ca1 100644 --- a/tests/test-org-roam-config-format.el +++ b/tests/test-org-roam-config-format.el @@ -147,5 +147,21 @@ Returns the formatted file content." (let ((result (test-format "Title" "id" "* Content"))) (should (string-match-p "#\\+FILETAGS: Topic\n\n\\* Content" result)))) +(defvar org-roam-capture-templates) + +(ert-deftest test-org-roam-config-immediate-insert-binding-is-dynamic () + "Normal: the immediate-insert template binding reaches the insert call. +Without the module's defvar, the byte-compiled let is a dead lexical +binding: org-roam-node-insert would see the untouched global templates +and :immediate-finish never applies -- the \"immediate\" insert opens a +capture buffer. Asserted behaviorally (not via special-variable-p, +whose answer differs between the package-loaded and bare batch envs)." + (let ((org-roam-capture-templates '(("d" "default"))) + seen) + (cl-letf (((symbol-function 'org-roam-node-insert) + (lambda (&rest _) (setq seen org-roam-capture-templates)))) + (cj/org-roam-node-insert-immediate nil)) + (should (equal seen '(("d" "default" :immediate-finish t)))))) + (provide 'test-org-roam-config-format) ;;; test-org-roam-config-format.el ends here diff --git a/tests/test-pre-commit-hook.bats b/tests/test-pre-commit-hook.bats new file mode 100644 index 00000000..413c71d0 --- /dev/null +++ b/tests/test-pre-commit-hook.bats @@ -0,0 +1,126 @@ +#!/usr/bin/env bats +# Tests for githooks/pre-commit — the secret scan and paren check. +# +# The scan reads its input through a pipeline: +# +# added_lines="$(git diff --cached ... | grep '^+' | grep -v '^+++' || true)" +# +# `grep` exits 1 when it matches nothing, which is the ordinary case, so the +# `|| true` has to stay. But with no `pipefail` it also swallows a failure of +# `git diff` itself, and an empty `added_lines` makes the scan search nothing, +# find nothing, and report clean. A gate that passes without looking is the +# failure this file exists to pin: the fail-open test drives a broken `git diff` +# and asserts the hook refuses rather than exiting 0. +# +# Each test builds a throwaway git repo in BATS_TEST_TMPDIR, so nothing touches +# the real repository or its hooks. + +setup() { + HOOK="${BATS_TEST_DIRNAME}/../githooks/pre-commit" + REPO="${BATS_TEST_TMPDIR}/repo" + mkdir -p "$REPO" + cd "$REPO" || return 1 + git init -q . + git config user.email t@example.com + git config user.name Test + # Split so the fixtures never appear as credential-shaped literals here. + AWS_TAIL="IOSFODNN7EXAMPLE" + WORD_TAIL="word" +} + +# Put a stub `git` ahead of the real one that fails for the staged-diff call +# and delegates everything else, so only the pipeline under test breaks. +break_staged_diff() { + mkdir -p "${BATS_TEST_TMPDIR}/bin" + cat > "${BATS_TEST_TMPDIR}/bin/git" <<'STUB' +#!/usr/bin/env bash +if [ "${1:-}" = "diff" ] && [ "${2:-}" = "--cached" ] && [ "${3:-}" = "-U0" ]; then + echo "simulated git failure" >&2 + exit 128 +fi +exec /usr/bin/git "$@" +STUB + chmod +x "${BATS_TEST_TMPDIR}/bin/git" + PATH="${BATS_TEST_TMPDIR}/bin:$PATH" +} + +# ------------------------------- Normal cases ------------------------------- + +@test "secret scan: blocks a staged AWS key" { + # Assembled at runtime: a literal key-shaped string in this file would trip + # the very hook under test on every commit that touches it, and this repo + # mirrors to a public remote. + printf 'aws = "%s"\n' "AKIA${AWS_TAIL}" > creds.txt + git add creds.txt + run "$HOOK" + [ "$status" -eq 1 ] + [[ "$output" == *"potential secret"* ]] +} + +@test "secret scan: blocks a staged keyword=value password" { + printf '%s = "%s"\n' "pass${WORD_TAIL}" "correcthorsebatterystaple" > conf.txt + git add conf.txt + run "$HOOK" + [ "$status" -eq 1 ] + [[ "$output" == *"potential secret"* ]] +} + +@test "secret scan: allows an ordinary staged file" { + printf 'just some prose\n' > notes.txt + git add notes.txt + run "$HOOK" + [ "$status" -eq 0 ] +} + +# ------------------------------ Boundary cases ------------------------------ + +@test "secret scan: allows a commit with nothing staged" { + run "$HOOK" + [ "$status" -eq 0 ] +} + +@test "paren check: blocks an unbalanced staged .el file" { + printf '(defun broken ()\n (message "no close"\n' > bad.el + git add bad.el + run "$HOOK" + [ "$status" -eq 1 ] + [[ "$output" == *"paren check failed"* ]] +} + +@test "paren check: allows a balanced staged .el file" { + printf '(defun fine ()\n (message "ok"))\n' > good.el + git add good.el + run "$HOOK" + [ "$status" -eq 0 ] +} + +# -------------------------------- Error cases ------------------------------- + +@test "secret scan: refuses to pass when the staged diff cannot be read" { + # The scan must not report clean after searching nothing. Without a + # pipefail-aware guard the broken diff yields an empty added_lines and the + # hook exits 0, letting a real secret through unscanned. + printf 'aws = "%s"\n' "AKIA${AWS_TAIL}" > creds.txt + git add creds.txt + break_staged_diff + run "$HOOK" + [ "$status" -ne 0 ] +} + +@test "paren check: refuses to pass when the staged file list cannot be read" { + printf '(defun broken ()\n (message "no close"\n' > bad.el + git add bad.el + mkdir -p "${BATS_TEST_TMPDIR}/bin2" + cat > "${BATS_TEST_TMPDIR}/bin2/git" <<'STUB' +#!/usr/bin/env bash +if [ "${1:-}" = "diff" ] && [ "${2:-}" = "--cached" ] && [ "${3:-}" = "--name-only" ]; then + echo "simulated git failure" >&2 + exit 128 +fi +exec /usr/bin/git "$@" +STUB + chmod +x "${BATS_TEST_TMPDIR}/bin2/git" + PATH="${BATS_TEST_TMPDIR}/bin2:$PATH" + run "$HOOK" + [ "$status" -ne 0 ] +} diff --git a/tests/test-prog-c--tool-warnings.el b/tests/test-prog-c--tool-warnings.el new file mode 100644 index 00000000..9d4da57e --- /dev/null +++ b/tests/test-prog-c--tool-warnings.el @@ -0,0 +1,34 @@ +;;; test-prog-c--tool-warnings.el --- Load-time missing-tool warnings -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit flagged clangd for the load-time missing-tool +;; warning pyright/prettier already have. clang-format is the same +;; class: its use-package block gates on `:if (executable-find ...)', +;; which evaluates once at startup, so an absent binary silently +;; disables the format key until the next restart — the warn is the +;; only visible trace. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-c) + +(ert-deftest test-prog-c-warns-when-tools-missing () + "Error: loading without the C tools on PATH warns for each one." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-c.el" user-emacs-directory) nil t)) + (dolist (tool '("clangd" "clang-format")) + (should (cl-some (lambda (m) (string-match-p (regexp-quote tool) m)) + warned))))) + +(provide 'test-prog-c--tool-warnings) +;;; test-prog-c--tool-warnings.el ends here diff --git a/tests/test-prog-general--pin-go-treesit-revision.el b/tests/test-prog-general--pin-go-treesit-revision.el new file mode 100644 index 00000000..42845b4f --- /dev/null +++ b/tests/test-prog-general--pin-go-treesit-revision.el @@ -0,0 +1,51 @@ +;;; test-prog-general--pin-go-treesit-revision.el --- Go grammar pinning -*- lexical-binding: t; -*- + +;;; Commentary: +;; The treesit-auto Go recipe is pinned for compatibility with Emacs 30.2. +;; Keep the mutation independent of cl-defstruct's compile-time setter +;; expansion: prog-general is loaded before treesit-auto defines that setter +;; during a normal startup. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; Deliberately put `revision' at a different offset from treesit-auto's real +;; struct. The production helper must discover the slot rather than hard-code +;; the package's current vector layout. +(cl-defstruct treesit-auto-recipe lang revision url) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +(ert-deftest test-prog-general-pin-go-treesit-revision-updates-go () + "Normal: the Go recipe receives the supported grammar revision." + (let* ((go (make-treesit-auto-recipe + :lang 'go :revision "main" :url "https://example.test/go")) + (python (make-treesit-auto-recipe + :lang 'python :revision "main" + :url "https://example.test/python"))) + (cj/treesit-auto-pin-go-revision (list python go)) + (should (equal (treesit-auto-recipe-revision go) "v0.19.1")) + (should (equal (treesit-auto-recipe-revision python) "main")))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-no-go-is-no-op () + "Boundary: a recipe list without Go remains unchanged." + (let ((python (make-treesit-auto-recipe + :lang 'python :revision "main" + :url "https://example.test/python"))) + (should-not (cj/treesit-auto-pin-go-revision (list python))) + (should (equal (treesit-auto-recipe-revision python) "main")))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-empty-is-no-op () + "Boundary: an empty recipe list does not signal an error." + (should-not (cj/treesit-auto-pin-go-revision nil))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-malformed-recipe-errors () + "Error: a malformed recipe signals instead of silently skipping the pin." + (should-error (cj/treesit-auto-pin-go-revision '(not-a-recipe)) + :type 'wrong-type-argument)) + +(provide 'test-prog-general--pin-go-treesit-revision) +;;; test-prog-general--pin-go-treesit-revision.el ends here diff --git a/tests/test-prog-go--classic-mode-hooks.el b/tests/test-prog-go--classic-mode-hooks.el new file mode 100644 index 00000000..a9defe2e --- /dev/null +++ b/tests/test-prog-go--classic-mode-hooks.el @@ -0,0 +1,46 @@ +;;; test-prog-go--classic-mode-hooks.el --- Classic go-mode hooks + gopls warn -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found the Go setup hooks attached to go-ts-mode +;; only, so a fallback to classic go-mode silently lost indent, keys, +;; and LSP. It also flagged gopls for the load-time missing-tool +;; warning pyright/prettier already have; that warn is only honest if +;; ~/go/bin is on `exec-path' at load time (it used to join only in +;; go-mode's deferred :config, so gopls installed there read as +;; missing). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-go) + +(ert-deftest test-prog-go-hooks-cover-classic-go-mode () + "Normal: classic go-mode runs the same setup + keybindings as go-ts-mode." + (dolist (hook '(go-mode-hook go-ts-mode-hook)) + (should (memq #'cj/go-setup (symbol-value hook))) + (should (memq #'cj/go-mode-keybindings (symbol-value hook))))) + +(ert-deftest test-prog-go-bin-path-on-exec-path-at-load () + "Normal: ~/go/bin joins `exec-path' at module load, not first go buffer. +The load-time gopls warn resolves through `exec-path'; registering the +Go bin directory only in go-mode's deferred :config would make gopls +installed there warn as missing on every start." + (should (member go-bin-path exec-path))) + +(ert-deftest test-prog-go-warns-when-gopls-missing () + "Error: loading the module without gopls on PATH warns about gopls." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-go.el" user-emacs-directory) nil t)) + (should (cl-some (lambda (m) (string-match-p "gopls" m)) warned)))) + +(provide 'test-prog-go--classic-mode-hooks) +;;; test-prog-go--classic-mode-hooks.el ends here diff --git a/tests/test-prog-shell--tool-warnings.el b/tests/test-prog-shell--tool-warnings.el new file mode 100644 index 00000000..37c1e559 --- /dev/null +++ b/tests/test-prog-shell--tool-warnings.el @@ -0,0 +1,34 @@ +;;; test-prog-shell--tool-warnings.el --- Load-time missing-tool warnings -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit flagged bash-language-server, shfmt, and shellcheck +;; for the load-time missing-tool warnings pyright/prettier already +;; have. The shfmt and flycheck use-package blocks gate on `:if +;; (executable-find ...)', which evaluates once at startup — an absent +;; tool silently disables that setup until the next restart, so the +;; warn is the only visible trace. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-shell) + +(ert-deftest test-prog-shell-warns-when-tools-missing () + "Error: loading without the shell tools on PATH warns for each one." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-shell.el" user-emacs-directory) nil t)) + (dolist (tool '("bash-language-server" "shfmt" "shellcheck")) + (should (cl-some (lambda (m) (string-match-p (regexp-quote tool) m)) + warned))))) + +(provide 'test-prog-shell--tool-warnings) +;;; test-prog-shell--tool-warnings.el ends here diff --git a/tests/test-prog-webdev--classic-and-web-mode-hooks.el b/tests/test-prog-webdev--classic-and-web-mode-hooks.el new file mode 100644 index 00000000..20fc2fb8 --- /dev/null +++ b/tests/test-prog-webdev--classic-and-web-mode-hooks.el @@ -0,0 +1,78 @@ +;;; test-prog-webdev--classic-and-web-mode-hooks.el --- Classic js + web-mode setup hooks -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found the webdev setup hooks attached to the +;; tree-sitter modes only, so a grammar-unavailable fallback to classic +;; js-mode silently lost indent/keys/LSP, and web-mode got the format +;; key but none of the promised setup (no company/flyspell/LSP in HTML +;; buffers). These tests pin the classic js-mode hooks and the +;; web-mode setup hook, plus the html-language-server guard that keeps +;; LSP silent on machines without the server. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-webdev) + +(ert-deftest test-prog-webdev-hooks-cover-classic-js-mode () + "Normal: classic js-mode runs the same setup + keybindings as js-ts-mode." + (should (memq #'cj/webdev-setup js-mode-hook)) + (should (memq #'cj/webdev-keybindings js-mode-hook))) + +(ert-deftest test-prog-webdev-web-mode-hook-runs-setup () + "Normal: web-mode runs `cj/web-mode-setup' alongside the keybindings." + (should (memq #'cj/web-mode-setup web-mode-hook)) + (should (memq #'cj/webdev-keybindings web-mode-hook))) + +(ert-deftest test-prog-webdev-web-mode-setup-sets-buffer-local-preferences () + "Normal: web-mode setup lands the shared webdev buffer preferences." + (with-temp-buffer + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) + (cj/web-mode-setup)) + (should (= fill-column 100)) + (should (= tab-width 2)) + (should-not indent-tabs-mode))) + +(ert-deftest test-prog-webdev-web-mode-setup-starts-lsp-when-html-server-on-path () + "Normal: with the html language server on PATH, `lsp-deferred' fires." + (with-temp-buffer + (let ((started nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'lsp-deferred) + (lambda (&rest _) (setq started t))) + ((symbol-function 'executable-find) + (lambda (path &rest _) + (when (equal path html-language-server-path) + "/usr/bin/vscode-html-language-server")))) + (cj/web-mode-setup)) + (should started)))) + +(ert-deftest test-prog-webdev-web-mode-setup-skips-lsp-without-html-server () + "Boundary: without the html language server, `lsp-deferred' is NOT called." + (with-temp-buffer + (let ((started nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'lsp-deferred) + (lambda (&rest _) (setq started t))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) + (cj/web-mode-setup)) + (should-not started)))) + +(provide 'test-prog-webdev--classic-and-web-mode-hooks) +;;; test-prog-webdev--classic-and-web-mode-hooks.el ends here diff --git a/tests/test-restclient-config--keymap.el b/tests/test-restclient-config--keymap.el new file mode 100644 index 00000000..7265c4f3 --- /dev/null +++ b/tests/test-restclient-config--keymap.el @@ -0,0 +1,29 @@ +;;; test-restclient-config--keymap.el --- Tests for the restclient prefix keymap -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins the C-; R prefix wiring. The bindings must go through +;; `cj/restclient-map' + `cj/register-prefix-map' (like the other C-; +;; prefixes), not raw `global-set-key' calls that silently depend on +;; keybindings.el having installed C-; first. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'restclient-config) + +;;; Normal Cases + +(ert-deftest test-restclient-keymap-registered-under-custom-prefix () + "Normal: cj/restclient-map is bound at R inside cj/custom-keymap." + (should (boundp 'cj/restclient-map)) + (should (eq cj/restclient-map (keymap-lookup cj/custom-keymap "R")))) + +(ert-deftest test-restclient-keymap-binds-new-buffer-and-open-file () + "Normal: the prefix map carries the two restclient commands." + (should (eq #'cj/restclient-new-buffer (keymap-lookup cj/restclient-map "n"))) + (should (eq #'cj/restclient-open-file (keymap-lookup cj/restclient-map "o")))) + +(provide 'test-restclient-config--keymap) +;;; test-restclient-config--keymap.el ends here diff --git a/tests/test-slack-config-reactions.el b/tests/test-slack-config-reactions.el index 491b8147..bfcf3e29 100644 --- a/tests/test-slack-config-reactions.el +++ b/tests/test-slack-config-reactions.el @@ -92,5 +92,13 @@ (let ((slack-current-buffer nil)) (should-error (cj/slack-message-add-reaction) :type 'user-error))) +(ert-deftest test-slack-config-message-add-reaction-errors-before-slack-loads () + "Error: a cold call before slack.el ever loads gives the friendly user-error. +The module defvars slack-current-buffer with no value, so until slack.el +binds it the variable is void -- a bare read signals void-variable instead +of the intended \"Not in a Slack buffer\"." + (makunbound 'slack-current-buffer) + (should-error (cj/slack-message-add-reaction) :type 'user-error)) + (provide 'test-slack-config-reactions) ;;; test-slack-config-reactions.el ends here diff --git a/tests/test-system-commands-resolve-and-run.el b/tests/test-system-commands-resolve-and-run.el index 9d92c5d6..3dae8cda 100644 --- a/tests/test-system-commands-resolve-and-run.el +++ b/tests/test-system-commands-resolve-and-run.el @@ -85,26 +85,34 @@ (put 'test-sc-confirm-cmd 'cj/system-confirm nil))) (ert-deftest test-system-cmd-strong-confirm-decline-aborts () - "Boundary: a strong-confirm var uses yes-or-no-p; declining aborts and -does not run the command." + "Boundary: a strong-confirm var asks a single y/n; declining aborts and +does not run the command. + +The strong path used to demand a typed \"yes\", and this test used to assert +that by erroring if `read-char-choice' was called at all. It now asserts the +opposite, because a long-form prompt is only as safe as it is answerable: on +2026-07-31 one became unanswerable when a second agent session held the +selected window, and the Emacs session had to be killed with buffers unsaved. +What survives the change is the part that mattered -- the prompt still has no +default, so RET and space re-prompt rather than confirming a shutdown." (defvar test-sc-strong-cmd "test-strong-cmd") (put 'test-sc-strong-cmd 'cj/system-confirm 'strong) (unwind-protect - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) nil)) - ((symbol-function 'read-char-choice) - (lambda (&rest _) (error "strong confirm must not use read-char-choice"))) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?n)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (error "strong confirm must not demand a typed yes"))) ((symbol-function 'start-process-shell-command) (lambda (&rest _) (error "shouldn't run")))) (should-error (cj/system-cmd 'test-sc-strong-cmd) :type 'user-error)) (put 'test-sc-strong-cmd 'cj/system-confirm nil))) (ert-deftest test-system-cmd-strong-confirm-accept-runs () - "Normal: a strong-confirm var runs the command when yes-or-no-p returns t." + "Normal: a strong-confirm var runs the command on a single y." (defvar test-sc-strong-cmd-2 "echo strong") (put 'test-sc-strong-cmd-2 'cj/system-confirm 'strong) (let (cmd-line) (unwind-protect - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y)) ((symbol-function 'start-process-shell-command) (lambda (_name _buf c) (setq cmd-line c) 'fake-proc)) ((symbol-function 'set-process-query-on-exit-flag) #'ignore) @@ -114,6 +122,29 @@ does not run the command." (put 'test-sc-strong-cmd-2 'cj/system-confirm nil)) (should (string-match-p "echo strong" cmd-line)))) +(ert-deftest test-system-cmd-strong-confirm-rejects-stray-keys () + "Boundary: the strong prompt offers only y and n, so a stray RET or space +cannot confirm an irreversible command. + +This is the protection the typed-\"yes\" form existed for, kept while the +answer became a single keystroke. Asserted on the accepted-character set +handed to `read-char-choice' rather than on the prompt text, because the set +is what actually decides." + (defvar test-sc-strong-cmd-3 "echo strong") + (put 'test-sc-strong-cmd-3 'cj/system-confirm 'strong) + (let (chars) + (unwind-protect + (cl-letf (((symbol-function 'read-char-choice) + (lambda (_prompt cs &rest _) (setq chars cs) ?n)) + ((symbol-function 'start-process-shell-command) + (lambda (&rest _) (error "shouldn't run")))) + (should-error (cj/system-cmd 'test-sc-strong-cmd-3) :type 'user-error)) + (put 'test-sc-strong-cmd-3 'cj/system-confirm nil)) + (should (equal (sort (copy-sequence chars) #'<) '(?N ?Y ?n ?y))) + (should-not (memq ?\r chars)) + (should-not (memq ?\n chars)) + (should-not (memq ?\s chars)))) + ;;; cj/system-cmd--emacs-service-available-p (ert-deftest test-system-cmd-service-available-true-on-zero-exit () @@ -230,5 +261,37 @@ kill-emacs directly (the service owns the daemon lifecycle)." (cj/system-command-menu)) (should (eq called 'cj/system-cmd-lock)))) +;;; Lock command resolves the locker at call time + +(defun test-system-cmd--run-lock-capturing () + "Run the lock command; return the shell command line it launched." + (let (cmd-line) + (cl-letf (((symbol-function 'start-process-shell-command) + (lambda (_name _buf c) (setq cmd-line c) 'fake-proc)) + ((symbol-function 'set-process-query-on-exit-flag) #'ignore) + ((symbol-function 'set-process-sentinel) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/system-cmd-lock)) + cmd-line)) + +(ert-deftest test-system-cmd-lock-follows-session-type-at-call-time () + "Normal: the locker tracks the live session type, not the load-time bake. +A daemon started before WAYLAND_DISPLAY was imported used to freeze the +locker to slock forever; Lock then failed silently on Wayland." + (let ((lockscreen-cmd nil)) + (cl-letf (((symbol-function 'env-wayland-p) (lambda () t))) + (should (string-match-p "loginctl lock-session" + (test-system-cmd--run-lock-capturing)))) + (cl-letf (((symbol-function 'env-wayland-p) (lambda () nil))) + (should (string-match-p "slock" + (test-system-cmd--run-lock-capturing)))))) + +(ert-deftest test-system-cmd-lock-explicit-override-wins () + "Boundary: a user-set lockscreen-cmd overrides the session-type resolution." + (let ((lockscreen-cmd "my-locker --now")) + (cl-letf (((symbol-function 'env-wayland-p) (lambda () t))) + (should (string-match-p "my-locker --now" + (test-system-cmd--run-lock-capturing)))))) + (provide 'test-system-commands-resolve-and-run) ;;; test-system-commands-resolve-and-run.el ends here diff --git a/tests/test-system-defaults-functions.el b/tests/test-system-defaults-functions.el index c603fc7e..4b647166 100644 --- a/tests/test-system-defaults-functions.el +++ b/tests/test-system-defaults-functions.el @@ -162,5 +162,36 @@ and the rendered S-expression lands in the log." (should (string-match-p ":slot" contents))))) (delete-file comp-warnings-log)))) +(ert-deftest test-system-defaults-log-comp-warning-unwritable-log-does-not-signal () + "Error: an unwritable log path must not signal. +The function is `:before-until' advice on `display-warning'; a signal here +propagates out of `display-warning' and breaks warning display for every +async native-comp notice. It swallows the write failure and still returns +t (the warning stays suppressed), rather than crashing." + (let ((comp-warnings-log "/proc/nonexistent-dir/cannot-write.log")) + (should (eq t (cj/log-comp-warning 'comp "boom"))))) + +(ert-deftest test-system-defaults-log-comp-warning-caps-log-growth () + "Boundary: the log is bounded — once it exceeds the cap, a further write +resets it (deletes the old file, keeping only the new entry) rather than +growing without limit. A hard reset, not a tail-trim: on overflow the old +history is discarded, which is fine for a transient diagnostic log." + (let ((comp-warnings-log (make-temp-file "comp-warnings-" nil ".log"))) + (unwind-protect + (progn + ;; Seed the file well over the cap. + (with-temp-file comp-warnings-log + (insert (make-string (1+ cj/comp-warnings-log-max-bytes) ?x))) + (should (> (file-attribute-size (file-attributes comp-warnings-log)) + cj/comp-warnings-log-max-bytes)) + (cj/log-comp-warning 'comp "after the cap") + (should (<= (file-attribute-size (file-attributes comp-warnings-log)) + cj/comp-warnings-log-max-bytes)) + ;; The newest entry survives the trim. + (with-temp-buffer + (insert-file-contents comp-warnings-log) + (should (string-match-p "after the cap" (buffer-string))))) + (delete-file comp-warnings-log)))) + (provide 'test-system-defaults-functions) ;;; test-system-defaults-functions.el ends here diff --git a/tests/test-system-lib--ensure-marginalia-align.el b/tests/test-system-lib--ensure-marginalia-align.el new file mode 100644 index 00000000..33ff2ba2 --- /dev/null +++ b/tests/test-system-lib--ensure-marginalia-align.el @@ -0,0 +1,57 @@ +;;; test-system-lib--ensure-marginalia-align.el --- Tests for marginalia category registration -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Custom completion categories (cj-music-file, cj-radio-station, and every +;; category passed to the system-lib table helpers) bypass marginalia, so +;; their annotations never get its right-alignment even with marginalia-align +;; set. The registration helper adds a builtin entry per category so the +;; table's own annotation function renders through marginalia's aligned field. + +;;; Code: + +(require 'ert) + +;; The module's bare defvar marks this special only file-locally; declare it +;; here too so `let' binds dynamically (the scope-shadowing trap). +(defvar marginalia-annotator-registry) + +(require 'system-lib) + +;;; Normal Cases + +(ert-deftest test-system-lib-ensure-marginalia-align-registers-category () + "Normal: an unregistered category gains a builtin registry entry." + (let ((marginalia-annotator-registry '((file some-annotator builtin none)))) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (should (equal (assq 'cj-test-category marginalia-annotator-registry) + '(cj-test-category builtin none))))) + +(ert-deftest test-system-lib-ensure-marginalia-align-idempotent () + "Normal: registering the same category twice leaves one entry." + (let ((marginalia-annotator-registry '())) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (should (= 1 (length marginalia-annotator-registry))))) + +;;; Boundary Cases + +(ert-deftest test-system-lib-ensure-marginalia-align-preserves-existing-entry () + "Boundary: a category with an existing (possibly custom) entry is untouched." + (let ((marginalia-annotator-registry '((cj-test-category my-custom-annotator)))) + (cj/completion-ensure-marginalia-align 'cj-test-category) + (should (equal (assq 'cj-test-category marginalia-annotator-registry) + '(cj-test-category my-custom-annotator))))) + +;;; Error Cases + +(ert-deftest test-system-lib-ensure-marginalia-align-marginalia-absent-noop () + "Error: without marginalia loaded (registry void) the helper is a silent +no-op -- annotations just stay unaligned, nothing breaks." + ;; marginalia is not loadable in the batch environment, so the global + ;; registry is genuinely void outside the `let's above. + (should-not (cj/completion-ensure-marginalia-align 'cj-test-category))) + +(provide 'test-system-lib--ensure-marginalia-align) +;;; test-system-lib--ensure-marginalia-align.el ends here diff --git a/tests/test-system-lib-confirm-destructive.el b/tests/test-system-lib-confirm-destructive.el new file mode 100644 index 00000000..4fc96e21 --- /dev/null +++ b/tests/test-system-lib-confirm-destructive.el @@ -0,0 +1,141 @@ +;;; test-system-lib-confirm-destructive.el --- Tests for cj/confirm-destructive -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/confirm-destructive', the confirmation used for +;; irreversible actions: file destruction, overwrites, power-off. +;; +;; The contract has two halves, and they pull against each other: +;; +;; 1. One keystroke. This replaced a typed-"yes" prompt on 2026-07-31, after +;; one became unanswerable -- a second agent session held the selected +;; window while the prompt waited in another frame, so keystrokes went to a +;; terminal and the Emacs session had to be killed with buffers unsaved. A +;; long-form prompt is only as safe as it is answerable. +;; +;; 2. No default. Only y and n answer. A stray RET or space re-prompts +;; instead of confirming, which is the accidental-confirm protection the +;; long form existed for, and it survives the change. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'system-lib) + +;;; Normal Cases + +(ert-deftest test-system-lib-confirm-destructive-returns-t-on-y () + "Normal: a y answer confirms." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y))) + (should (eq (cj/confirm-destructive "Really? ") t)))) + +(ert-deftest test-system-lib-confirm-destructive-returns-nil-on-n () + "Normal: an n answer declines." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?n))) + (should (eq (cj/confirm-destructive "Really? ") nil)))) + +;;; Boundary Cases + +(ert-deftest test-system-lib-confirm-destructive-accepts-uppercase () + "Boundary: a capital Y confirms and a capital N declines, so the answer +does not depend on the shift key or caps lock." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?Y))) + (should (eq (cj/confirm-destructive "Really? ") t))) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?N))) + (should (eq (cj/confirm-destructive "Really? ") nil)))) + +(ert-deftest test-system-lib-confirm-destructive-offers-only-y-and-n () + "Boundary: RET, space and every other key are refused. + +This is the protection that justified the old typed-\"yes\" form, kept now +that the answer is a single keystroke. Asserted on the character set handed +to `read-char-choice', which is what actually decides, rather than on the +prompt text, which only describes." + (let (chars) + (cl-letf (((symbol-function 'read-char-choice) + (lambda (_prompt cs &rest _) (setq chars cs) ?n))) + (cj/confirm-destructive "Really? ")) + (should (equal (sort (copy-sequence chars) #'<) '(?N ?Y ?n ?y))) + (should-not (memq ?\r chars)) + (should-not (memq ?\n chars)) + (should-not (memq ?\s chars)))) + +(ert-deftest test-system-lib-confirm-destructive-is-single-keystroke () + "Boundary: it never routes through `yes-or-no-p'. + +The regression this file guards. Binding `use-short-answers' to nil for the +call, which is what the old implementation did, is exactly the shape that +produced an unanswerable prompt." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (error "must not demand a typed yes")))) + (should (eq (cj/confirm-destructive "Really? ") t)))) + +(ert-deftest test-system-lib-confirm-destructive-ignores-short-answer-setting () + "Boundary: the answer is one key whether or not `use-short-answers' is set. +The global default is t, but nothing about this prompt should depend on it." + (dolist (setting '(t nil)) + (let ((use-short-answers setting)) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (error "must not demand a typed yes")))) + (should (eq (cj/confirm-destructive "Really? ") t)))))) + +(ert-deftest test-system-lib-confirm-destructive-discards-type-ahead () + "Boundary: pending input is discarded before the key is read. + +The regression that made this necessary. `read-char-choice' reads the input +queue, so a key typed before the prompt appeared would answer it: a queued y +would confirm a shutdown or a file deletion instantly. The typed-\"yes\" +form absorbed such a key harmlessly, so dropping it without this guard would +have traded a rare annoyance for a rare catastrophe. + +Asserted on ordering, since that is the whole property: the discard has to +happen before the read, not merely somewhere in the function." + (let ((events '())) + (cl-letf (((symbol-function 'discard-input) + (lambda (&rest _) (push 'discard events) nil)) + ((symbol-function 'read-char-choice) + (lambda (&rest _) (push 'read events) ?y))) + (should (eq (cj/confirm-destructive "Really? ") t))) + (should (equal (nreverse events) '(discard read))))) + +;;; Error Cases + +(ert-deftest test-system-lib-confirm-destructive-declines-on-other-char () + "Error: anything that is not y or n declines rather than confirming. + +`read-char-choice' normally loops until it gets a listed character, but it +can return outside the set -- `read-char-from-minibuffer' yields RET when the +minibuffer result is empty. On an irreversible action the safe reading of an +unexpected answer is no." + (dolist (ch (list ?\r ?\n ?\s ?q ?\C-m)) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ch))) + (should-not (cj/confirm-destructive "Really? "))))) + +(ert-deftest test-system-lib-confirm-destructive-propagates-quit () + "Error: C-g aborts the caller rather than reading as a confirmation. +Swallowing the quit here would turn an abort into a yes on an irreversible +action." + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (signal 'quit nil)))) + ;; `should-error' cannot express this: quit is not an error, so ERT lets + ;; it through and reports the test as QUIT rather than passed. Catching + ;; it here is what makes the assertion a real pass or fail. + (should (eq 'quit (condition-case nil + (progn (cj/confirm-destructive "Really? ") + 'returned-normally) + (quit 'quit)))))) + +(ert-deftest test-system-lib-confirm-destructive-prompt-shows-choices () + "Error: the prompt names the keys that answer, so an unfamiliar prompt is +not a guessing game." + (let (prompt) + (cl-letf (((symbol-function 'read-char-choice) + (lambda (p &rest _) (setq prompt p) ?n))) + (cj/confirm-destructive "Delete everything? ")) + (should (string-match-p "Delete everything\\?" prompt)) + (should (string-match-p "y or n" prompt)))) + +(provide 'test-system-lib-confirm-destructive) +;;; test-system-lib-confirm-destructive.el ends here diff --git a/tests/test-system-lib-confirm-strong.el b/tests/test-system-lib-confirm-strong.el deleted file mode 100644 index 26c00822..00000000 --- a/tests/test-system-lib-confirm-strong.el +++ /dev/null @@ -1,37 +0,0 @@ -;;; 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-telega-config--docker-pin.el b/tests/test-telega-config--docker-pin.el new file mode 100644 index 00000000..894dbfdd --- /dev/null +++ b/tests/test-telega-config--docker-pin.el @@ -0,0 +1,93 @@ +;;; test-telega-config--docker-pin.el --- Tests for the telega docker image pin -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for pinning the telega-server container image. +;; +;; telega infers its image from `telega-tdlib-min-version' and only pins to a +;; version tag when min and max versions are equal and the version ends in +;; ".0". This config has min "1.8.64" and max nil, so the inference always +;; falls through to "zevlg/telega-server:latest" -- a moving tag that can +;; swap the server out from under a fixed elisp version without notice. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'telega-config) + +;; -- cj/--telega-docker-pinned-image ----------------------------------------- + +(ert-deftest test-telega-config-pin-returns-configured-reference () + "Normal: a configured pin is returned verbatim." + (let ((cj/telega-docker-image "zevlg/telega-server@sha256:abc123")) + (should (equal (cj/--telega-docker-pinned-image) + "zevlg/telega-server@sha256:abc123")))) + +(ert-deftest test-telega-config-pin-nil-when-unset () + "Boundary: no pin returns nil so telega's own inference stays in charge." + (let ((cj/telega-docker-image nil)) + (should-not (cj/--telega-docker-pinned-image)))) + +(ert-deftest test-telega-config-pin-nil-for-empty-string () + "Boundary: an empty or whitespace pin is not a reference. +An empty string would otherwise reach the docker command line as a blank +image argument, which fails in a way that looks unrelated to this setting." + (let ((cj/telega-docker-image "")) + (should-not (cj/--telega-docker-pinned-image))) + (let ((cj/telega-docker-image " ")) + (should-not (cj/--telega-docker-pinned-image)))) + +(ert-deftest test-telega-config-pin-nil-for-non-string () + "Error: a non-string pin is ignored rather than passed to the shell." + (let ((cj/telega-docker-image 'latest)) + (should-not (cj/--telega-docker-pinned-image))) + (let ((cj/telega-docker-image 42)) + (should-not (cj/--telega-docker-pinned-image)))) + +(ert-deftest test-telega-config-pin-trims-surrounding-whitespace () + "Boundary: a pin with stray whitespace is trimmed, not rejected. +A trailing newline is easy to introduce when pasting a digest from docker." + (let ((cj/telega-docker-image " zevlg/telega-server@sha256:abc123\n")) + (should (equal (cj/--telega-docker-pinned-image) + "zevlg/telega-server@sha256:abc123")))) + +;; -- cj/--telega-docker-image-name (the advice) ------------------------------ + +(ert-deftest test-telega-config-image-advice-prefers-the-pin () + "Normal: with a pin set, the advice returns it instead of calling telega." + (let ((cj/telega-docker-image "zevlg/telega-server@sha256:abc123") + (called nil)) + (should (equal (cj/--telega-docker-image-name + (lambda () (setq called t) "zevlg/telega-server:latest")) + "zevlg/telega-server@sha256:abc123")) + (should-not called))) + +(ert-deftest test-telega-config-image-advice-delegates-without-a-pin () + "Boundary: with no pin, telega's own inference is used unchanged. +Removing the pin must restore stock behavior rather than break the image +name, so this stays a reversible setting." + (let ((cj/telega-docker-image nil)) + (should (equal (cj/--telega-docker-image-name + (lambda () "zevlg/telega-server:latest")) + "zevlg/telega-server:latest")))) + +(ert-deftest test-telega-config-image-advice-is-named-and-removable () + "Normal: the advice is a named function so it can be removed by reference." + (should (fboundp 'cj/--telega-docker-image-name))) + +(ert-deftest test-telega-config-pin-default-is-a-digest-reference () + "Normal: the shipped default pins by digest, not by a floating tag. +A tag pin (:latest, or even a version tag upstream can re-push) still +moves; a digest names one immutable image. + +Reads the defcustom's standard value rather than the live variable, so +customizing the pin (including to nil, handing the choice back to telega) +is not a test failure -- only changing the shipped default is." + (let ((default (eval (car (get 'cj/telega-docker-image 'standard-value)) t))) + (should (stringp default)) + (should (string-match-p "@sha256:[0-9a-f]\\{64\\}\\'" default)))) + +(provide 'test-telega-config--docker-pin) +;;; test-telega-config--docker-pin.el ends here diff --git a/tests/test-telega-config--server-death.el b/tests/test-telega-config--server-death.el new file mode 100644 index 00000000..1151fa7e --- /dev/null +++ b/tests/test-telega-config--server-death.el @@ -0,0 +1,131 @@ +;;; test-telega-config--server-death.el --- Tests for the telega-server death alert -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the telega-server death sentinel. telega's own sentinel only +;; calls `message' on an abnormal exit, which scrolls away unseen -- so a +;; dead server reads as a quiet Telegram. These pin the alert that replaces +;; that silence. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'telega-config) + +;; -- cj/--telega-server-death-p ---------------------------------------------- + +(ert-deftest test-telega-config-death-p-nonzero-status-is-death () + "Normal: a non-zero exit status is an abnormal death." + (should (cj/--telega-server-death-p 1)) + (should (cj/--telega-server-death-p 139))) + +(ert-deftest test-telega-config-death-p-segv-signal-is-death () + "Normal: a signal number (SIGSEGV is 11) counts as death. +This is the observed failure -- the server segfaults rather than exiting." + (should (cj/--telega-server-death-p 11))) + +(ert-deftest test-telega-config-death-p-zero-is-clean-exit () + "Boundary: exit status 0 is a clean shutdown and must not alert. +Quitting telega deliberately would otherwise page on every exit." + (should-not (cj/--telega-server-death-p 0))) + +(ert-deftest test-telega-config-death-p-nil-is-not-death () + "Boundary: nil status (no status available) is not a death." + (should-not (cj/--telega-server-death-p nil))) + +(ert-deftest test-telega-config-death-p-non-integer-is-not-death () + "Error: a non-integer status returns nil rather than signalling. +`process-exit-status' is documented to return an integer, but this runs +inside telega's sentinel where an error would disrupt telega's own cleanup." + (should-not (cj/--telega-server-death-p "segfault")) + (should-not (cj/--telega-server-death-p 'exited))) + +;; -- cj/--telega-server-exit-status ------------------------------------------ + +(ert-deftest test-telega-config-exit-status-nil-for-non-process () + "Error: a nil or non-process argument yields nil, not a signal. +The sentinel hands us whatever it has; a bad object must not break telega." + (should-not (cj/--telega-server-exit-status nil)) + (should-not (cj/--telega-server-exit-status "not-a-process"))) + +;; -- cj/--telega-server-death-body ------------------------------------------- + +(ert-deftest test-telega-config-death-body-names-status-and-effect () + "Normal: the body carries the status and says coverage is affected. +The status distinguishes a segfault from a clean kill; the effect is why +the reader should care." + (let ((body (cj/--telega-server-death-body 11 "segmentation fault\n"))) + (should (string-match-p "11" body)) + (should (string-match-p "Telegram" body)))) + +(ert-deftest test-telega-config-death-body-strips-trailing-newline () + "Boundary: a sentinel event string ends in a newline; it must not survive. +A trailing newline in a desktop notification body renders as dead space." + (let ((body (cj/--telega-server-death-body 11 "segmentation fault\n"))) + (should-not (string-suffix-p "\n" body)))) + +(ert-deftest test-telega-config-death-body-handles-empty-event () + "Boundary: an empty or nil event still produces a usable body." + (should (stringp (cj/--telega-server-death-body 11 nil))) + (should (stringp (cj/--telega-server-death-body 11 ""))) + (should (string-match-p "11" (cj/--telega-server-death-body 11 nil)))) + +(ert-deftest test-telega-config-death-body-handles-unicode-event () + "Boundary: a non-ASCII event string passes through intact." + (let ((body (cj/--telega-server-death-body 1 "ошибка сервера\n"))) + (should (string-match-p "ошибка" body)))) + +;; -- cj/--telega-server-notify-death (the advice) ---------------------------- + +(defmacro test-telega-config--with-status (status captured &rest body) + "Run BODY with the exit status forced to STATUS. +Notification calls are captured into CAPTURED as (TITLE . BODY) pairs." + (declare (indent 2)) + `(let ((,captured nil)) + (cl-letf (((symbol-function 'cj/--telega-server-exit-status) + (lambda (&rest _) ,status)) + ((symbol-function 'cj/--telega-server-send-notification) + (lambda (title body) (push (cons title body) ,captured)))) + ,@body))) + +(ert-deftest test-telega-config-notify-fires-on-abnormal-exit () + "Normal: an abnormal exit sends exactly one notification." + (test-telega-config--with-status 11 sent + (cj/--telega-server-notify-death nil "segmentation fault\n") + (should (= 1 (length sent))) + (should (string-match-p "telega" (downcase (car (car sent))))))) + +(ert-deftest test-telega-config-notify-silent-on-clean-exit () + "Boundary: a clean exit sends nothing. +Deliberately quitting telega must not page." + (test-telega-config--with-status 0 sent + (cj/--telega-server-notify-death nil "finished\n") + (should-not sent))) + +(ert-deftest test-telega-config-notify-silent-without-status () + "Boundary: no recoverable status sends nothing rather than a bare alert." + (test-telega-config--with-status nil sent + (cj/--telega-server-notify-death nil "gone\n") + (should-not sent))) + +(ert-deftest test-telega-config-notify-contains-notifier-errors () + "Error: a failing notifier must not escape into telega's sentinel. +This runs as :after advice on `telega-server--sentinel'; an error here +would abort telega's own status handling and its relogin path." + (cl-letf (((symbol-function 'cj/--telega-server-exit-status) + (lambda (&rest _) 11)) + ((symbol-function 'cj/--telega-server-send-notification) + (lambda (&rest _) (error "notifier unavailable")))) + (should (progn (cj/--telega-server-notify-death nil "segfault\n") t)))) + +(ert-deftest test-telega-config-notify-advice-is-named-and-removable () + "Normal: the sentinel advice is installed by name, so it can be removed. +An anonymous lambda can't be `advice-remove'd by reference, which strands +the old advice in a live daemon after the source stops installing it." + (should (fboundp 'cj/--telega-server-notify-death)) + (should (symbolp 'cj/--telega-server-notify-death))) + +(provide 'test-telega-config--server-death) +;;; test-telega-config--server-death.el ends here diff --git a/tests/test-test-runner--nil-global-directory.el b/tests/test-test-runner--nil-global-directory.el new file mode 100644 index 00000000..c70de5bd --- /dev/null +++ b/tests/test-test-runner--nil-global-directory.el @@ -0,0 +1,51 @@ +;;; test-test-runner--nil-global-directory.el --- Tests for the no-test-directory path -*- lexical-binding: t -*- + +;;; Commentary: +;; Outside a Projectile project, `cj/test--get-test-directory' falls back +;; to `cj/test-global-directory', which defaults to nil. These tests pin +;; the contract for that nil case: discovery helpers return nil instead +;; of crashing on (file-directory-p nil), and the interactive commands +;; signal `user-error' instead of wrong-type-argument. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'test-runner) + +(defmacro test-runner-nil-dir--outside-project (&rest body) + "Run BODY with no project root and a nil `cj/test-global-directory'." + (declare (indent 0)) + `(let ((cj/test-global-directory nil)) + (cl-letf (((symbol-function 'cj/test--project-root) + (lambda () nil))) + ,@body))) + +;;; Boundary Cases + +(ert-deftest test-test-runner-nil-dir-get-test-directory-returns-nil () + "Boundary: no project and no global dir yields nil, not an error." + (test-runner-nil-dir--outside-project + (should (null (cj/test--get-test-directory))))) + +(ert-deftest test-test-runner-nil-dir-get-test-files-returns-nil () + "Boundary: file discovery returns nil instead of crashing on a nil dir." + (test-runner-nil-dir--outside-project + (should (null (cj/test--get-test-files))))) + +;;; Error Cases + +(ert-deftest test-test-runner-nil-dir-load-all-signals-user-error () + "Error: `cj/test-load-all' signals `user-error', not wrong-type-argument." + (test-runner-nil-dir--outside-project + (should-error (cj/test-load-all) :type 'user-error))) + +(ert-deftest test-test-runner-nil-dir-focus-add-signals-user-error () + "Error: `cj/test-focus-add' signals `user-error', not wrong-type-argument." + (test-runner-nil-dir--outside-project + (should-error (cj/test-focus-add) :type 'user-error))) + +(provide 'test-test-runner--nil-global-directory) +;;; test-test-runner--nil-global-directory.el ends here diff --git a/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el b/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el index 36d82add..bcb9f833 100644 --- a/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el +++ b/tests/test-undead-buffers-kill-all-other-buffers-and-windows.el @@ -158,5 +158,22 @@ (kill-buffer buf)))))) (test-kill-all-other-buffers-and-windows-teardown))) +(ert-deftest test-kill-all-other-buffers-and-windows-with-prefix-still-kills () + "Boundary: C-u on the wrapper must still kill, not spam the undead list. +The delegated cj/kill-buffer-or-bury-alive reads current-prefix-arg, so a +prefixed wrapper call used to take the add-to-undead-list branch for every +buffer -- nothing killed, list spammed." + (test-kill-all-other-buffers-and-windows-setup) + (unwind-protect + (let ((cj/undead-buffer-list cj/undead-buffer-list) + (buf (generate-new-buffer "*test-prefix-kill*"))) + (unwind-protect + (let ((current-prefix-arg '(4))) + (cj/kill-all-other-buffers-and-windows) + (should-not (buffer-live-p buf)) + (should-not (member "*test-prefix-kill*" cj/undead-buffer-list))) + (when (buffer-live-p buf) (kill-buffer buf)))) + (test-kill-all-other-buffers-and-windows-teardown))) + (provide 'test-undead-buffers-kill-all-other-buffers-and-windows) ;;; test-undead-buffers-kill-all-other-buffers-and-windows.el ends here diff --git a/tests/test-validate-el-hook.bats b/tests/test-validate-el-hook.bats new file mode 100644 index 00000000..43c3569c --- /dev/null +++ b/tests/test-validate-el-hook.bats @@ -0,0 +1,97 @@ +#!/usr/bin/env bats +# Tests for .claude/hooks/validate-el.sh — the auto-test runner. +# +# The runner used to skip entirely above MAX_AUTO_TEST_FILES=20, with no else +# branch: nothing printed, exit 0, indistinguishable from a passing run. That +# was live for the three largest families here (calendar-sync 63 test files, +# music 45, ai-term 35), so every edit to those ran parens and byte-compile and +# zero tests, silently. +# +# The cap was removed rather than made loud, because its premise did not hold. +# Measured on this machine, running a whole family takes about a second: +# ai-term 208 tests in 1.0s, music 403 in 1.7s, calendar-sync 633 in 0.9s. It +# was also concealing a real cross-test pollution bug in calendar-sync that +# only appears when that family runs in one process. +# +# These tests pin that no file count is skipped. Each builds a synthetic +# project in BATS_TEST_TMPDIR and points CLAUDE_PROJECT_DIR at it, so nothing +# runs against the real tree. + +setup() { + HOOK="${BATS_TEST_DIRNAME}/../.claude/hooks/validate-el.sh" + PROJ="${BATS_TEST_TMPDIR}/proj" + mkdir -p "$PROJ/modules" "$PROJ/tests" + export CLAUDE_PROJECT_DIR="$PROJ" + printf '(provide (quote widget))\n' > "$PROJ/modules/widget.el" +} + +# N green test files matching the widget stem. +make_tests() { + local n="$1" i + for ((i = 1; i <= n; i++)); do + printf '(require (quote ert))\n(ert-deftest test-widget-%d () (should t))\n' \ + "$i" > "$PROJ/tests/test-widget-${i}.el" + done +} + +# One failing test file, to prove the run is real rather than merely quiet. +make_failing_test() { + printf '(require (quote ert))\n(ert-deftest test-widget-bad () (should nil))\n' \ + > "$PROJ/tests/test-widget-bad.el" +} + +hook_input() { + printf '{"tool_input":{"file_path":"%s"}}' "$PROJ/modules/widget.el" +} + +run_hook() { + run bash -c "$(printf '%q' "$HOOK") <<< '$(hook_input)'" +} + +# ------------------------------- Normal cases ------------------------------- + +@test "a small family runs and passes quietly" { + make_tests 3 + run_hook + [ "$status" -eq 0 ] +} + +@test "a failing test blocks, so a quiet pass means the tests really ran" { + make_tests 3 + make_failing_test + run_hook + [ "$status" -eq 2 ] + [[ "$output" == *"TESTS FAILED"* ]] +} + +# ------------------------------ Boundary cases ------------------------------ + +@test "at the old cap of 20 files: runs" { + make_tests 20 + run_hook + [ "$status" -eq 0 ] +} + +@test "past the old cap: still runs, no longer skipped" { + make_tests 21 + run_hook + [ "$status" -eq 0 ] + [[ "${output,,}" != *"skipped"* ]] +} + +@test "well past the old cap: a failure in file 63 is still caught" { + # The regression this guards: at 63 files the runner used to skip, so a red + # test in a big family reported clean. calendar-sync is exactly this size. + make_tests 63 + make_failing_test + run_hook + [ "$status" -eq 2 ] + [[ "$output" == *"TESTS FAILED"* ]] +} + +# -------------------------------- Error cases ------------------------------- + +@test "no matching tests: exits clean without running anything" { + run_hook + [ "$status" -eq 0 ] +} diff --git a/tests/test-vc-config--git-clone.el b/tests/test-vc-config--git-clone.el index 3b39ece2..46ce3d40 100644 --- a/tests/test-vc-config--git-clone.el +++ b/tests/test-vc-config--git-clone.el @@ -2,9 +2,11 @@ ;;; Commentary: ;; Unit tests for cj/--git-clone-dir-name (robust repo-dir derivation across -;; HTTPS, scp-style SSH, ssh:// and local URLs) and for cj/git-clone-clipboard-url -;; reporting a failed clone from the process exit status instead of silently -;; assuming the directory appeared. +;; HTTPS, scp-style SSH, ssh:// and local URLs), for the async clone process +;; wiring in cj/git-clone-clipboard-url (make-process argv, no shell), and +;; for the sentinel built by cj/--git-clone-make-sentinel (open on success, +;; surface the process buffer on failure). Sentinel tests drive real +;; short-lived processes rather than mocking process primitives. ;;; Code: @@ -14,6 +16,18 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'vc-config) +(defun test-vc-clone--run-sentinel (command sentinel buffer) + "Run COMMAND with SENTINEL and BUFFER; wait for process exit." + (let ((proc (make-process :name "test-vc-clone" + :buffer buffer + :command command + :sentinel sentinel))) + (while (process-live-p proc) + (accept-process-output proc 0.05)) + ;; Give the sentinel a chance to run after exit. + (accept-process-output nil 0.05) + proc)) + ;;; cj/--git-clone-dir-name — Normal Cases (ert-deftest test-vc-git-clone-dir-name-https-with-git-suffix () @@ -36,7 +50,7 @@ (should (equal "repo" (cj/--git-clone-dir-name "ssh://git@example.com/user/repo.git")))) -;;; Boundary Cases +;;; cj/--git-clone-dir-name — Boundary Cases (ert-deftest test-vc-git-clone-dir-name-ssh-scp-without-user () "Boundary: scp-style SSH with no user path (host:repo.git) still works. @@ -60,29 +74,110 @@ since there is no `/' separator." (should (equal "repo" (cj/--git-clone-dir-name " https://example.com/user/repo.git\n")))) -;;; cj/git-clone-clipboard-url — Error Cases +;;; cj/--git-clone-open — Normal / Boundary Cases -(ert-deftest test-vc-git-clone-clipboard-url-reports-clone-failure () - "Error: a nonzero git exit status surfaces a user-error, not silence. -Uses a real writable temp dir as the target (so the file predicates run -for real) and mocks only the clone process to fail." - (let ((target (make-temp-file "cj-clone-fail-" t))) +(ert-deftest test-vc-git-clone-open-finds-readme () + "Normal: a README in the clone is opened." + (let ((dir (make-temp-file "cj-clone-open-" t)) + (opened nil)) + (unwind-protect + (progn + (with-temp-file (expand-file-name "README.md" dir) (insert "hi")) + (cl-letf (((symbol-function 'find-file) + (lambda (f &rest _) (setq opened f))) + ((symbol-function 'dired) #'ignore)) + (cj/--git-clone-open dir) + (should (equal (expand-file-name "README.md" dir) opened)))) + (delete-directory dir t)))) + +(ert-deftest test-vc-git-clone-open-no-readme-dires () + "Boundary: with no README, the clone directory is dired." + (let ((dir (make-temp-file "cj-clone-open-" t)) + (dired-dir nil)) + (unwind-protect + (cl-letf (((symbol-function 'find-file) + (lambda (&rest _) (error "find-file should not run"))) + ((symbol-function 'dired) + (lambda (d &rest _) (setq dired-dir d)))) + (cj/--git-clone-open dir) + (should (equal dir dired-dir))) + (delete-directory dir t)))) + +;;; cj/--git-clone-make-sentinel — Normal / Error Cases + +(ert-deftest test-vc-git-clone-sentinel-success-opens-clone () + "Normal: a zero-exit clone process opens the clone directory." + (let ((buffer (generate-new-buffer " *test-clone-ok*")) + (opened nil)) + (unwind-protect + (cl-letf (((symbol-function 'cj/--git-clone-open) + (lambda (d) (setq opened d))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (test-vc-clone--run-sentinel + '("true") (cj/--git-clone-make-sentinel "url" "/tmp/clone-dst") buffer) + (should (equal "/tmp/clone-dst" opened))) + (kill-buffer buffer)))) + +(ert-deftest test-vc-git-clone-sentinel-failure-pops-process-buffer () + "Error: a nonzero exit surfaces the process buffer, never opens the clone." + (let ((buffer (generate-new-buffer " *test-clone-fail*")) + (opened nil) + (popped nil)) (unwind-protect - (cl-letf (((symbol-function 'call-process) (lambda (&rest _) 128)) - ((symbol-function 'pop-to-buffer) #'ignore) - ((symbol-function 'message) #'ignore)) - (should-error - (cj/git-clone-clipboard-url "https://example.com/user/repo.git" target) - :type 'user-error)) + (cl-letf (((symbol-function 'cj/--git-clone-open) + (lambda (d) (setq opened d))) + ((symbol-function 'pop-to-buffer) + (lambda (b &rest _) (setq popped b))) + ((symbol-function 'message) (lambda (&rest _) nil))) + (test-vc-clone--run-sentinel + '("false") (cj/--git-clone-make-sentinel "url" "/tmp/clone-dst") buffer) + (should-not opened) + (should (eq buffer popped))) + (kill-buffer buffer)))) + +;;; cj/git-clone-clipboard-url — Normal / Error Cases + +(ert-deftest test-vc-git-clone-clipboard-url-spawns-async-argv () + "Normal: the clone runs as an async process with a plain argv, no shell. +The `--' separator must precede the URL so a leading-dash URL cannot be +read as a git flag." + (let ((target (make-temp-file "cj-clone-async-" t)) + (spawned nil)) + (unwind-protect + (cl-letf (((symbol-function 'make-process) + (lambda (&rest args) + (setq spawned (plist-get args :command)) + nil)) + ((symbol-function 'message) (lambda (&rest _) nil))) + (cj/git-clone-clipboard-url "https://example.com/user/repo.git" target) + (should (equal (list "git" "clone" "--" + "https://example.com/user/repo.git" + (expand-file-name "repo" target)) + spawned))) (delete-directory target t)))) (ert-deftest test-vc-git-clone-clipboard-url-empty-clipboard-errors () "Error: an empty clipboard URL aborts before any clone attempt." - (let ((cloned nil)) - (cl-letf (((symbol-function 'call-process) - (lambda (&rest _) (setq cloned t) 0))) + (let ((spawned nil)) + (cl-letf (((symbol-function 'make-process) + (lambda (&rest _) (setq spawned t) nil))) (should-error (cj/git-clone-clipboard-url " " "/tmp") :type 'user-error)) - (should-not cloned))) + (should-not spawned))) + +(ert-deftest test-vc-git-clone-clipboard-url-existing-destination-errors () + "Error: an existing clone destination aborts before any clone attempt." + (let ((target (make-temp-file "cj-clone-exists-" t)) + (spawned nil)) + (unwind-protect + (progn + (make-directory (expand-file-name "repo" target)) + (cl-letf (((symbol-function 'make-process) + (lambda (&rest _) (setq spawned t) nil))) + (should-error + (cj/git-clone-clipboard-url "https://example.com/user/repo.git" target) + :type 'user-error)) + (should-not spawned)) + (delete-directory target t)))) (provide 'test-vc-config--git-clone) ;;; test-vc-config--git-clone.el ends here diff --git a/tests/test-vc-config--gutter-hunk-candidates.el b/tests/test-vc-config--gutter-hunk-candidates.el new file mode 100644 index 00000000..65db0c3c --- /dev/null +++ b/tests/test-vc-config--gutter-hunk-candidates.el @@ -0,0 +1,69 @@ +;;; test-vc-config--gutter-hunk-candidates.el --- Tests for cj/--git-gutter-hunk-candidates -*- lexical-binding: t -*- + +;;; Commentary: +;; Unit tests for cj/--git-gutter-hunk-candidates, the pure helper that +;; builds completion candidates (label . line) from git-gutter hunk start +;; lines against the current buffer's text. The interactive wrapper +;; cj/goto-git-gutter-diff-hunks maps git-gutter:diffinfos onto start +;; lines and delegates here. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'vc-config) + +;;; Normal Cases + +(ert-deftest test-vc-gutter-hunk-candidates-labels-carry-line-text () + "Normal: each candidate label contains the hunk line's text." + (with-temp-buffer + (insert "alpha\nbravo\ncharlie\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(2 3)))) + (should (= 2 (length candidates))) + (should (string-match-p "bravo" (car (nth 0 candidates)))) + (should (string-match-p "charlie" (car (nth 1 candidates))))))) + +(ert-deftest test-vc-gutter-hunk-candidates-cdr-is-start-line () + "Normal: each candidate's cdr is the hunk's start line number." + (with-temp-buffer + (insert "alpha\nbravo\ncharlie\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(1 3)))) + (should (equal '(1 3) (mapcar #'cdr candidates)))))) + +;;; Boundary Cases + +(ert-deftest test-vc-gutter-hunk-candidates-empty-input-returns-nil () + "Boundary: no hunks produce no candidates." + (with-temp-buffer + (insert "alpha\n") + (should (null (cj/--git-gutter-hunk-candidates '()))))) + +(ert-deftest test-vc-gutter-hunk-candidates-first-line () + "Boundary: a hunk on line 1 resolves to the first line's text." + (with-temp-buffer + (insert "alpha\nbravo\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(1)))) + (should (string-match-p "alpha" (caar candidates))) + (should (= 1 (cdar candidates)))))) + +(ert-deftest test-vc-gutter-hunk-candidates-unicode-line-text () + "Boundary: line text with unicode survives into the label." + (with-temp-buffer + (insert "naïve — 日本語\n") + (let ((candidates (cj/--git-gutter-hunk-candidates '(1)))) + (should (string-match-p "日本語" (caar candidates)))))) + +;;; Error Cases + +(ert-deftest test-vc-goto-git-gutter-diff-hunks-no-hunks-user-error () + "Error: the command signals `user-error' when the buffer has no hunks." + (with-temp-buffer + (setq-local git-gutter:diffinfos nil) + (cl-letf (((symbol-function 'require) (lambda (&rest _) nil))) + (should-error (cj/goto-git-gutter-diff-hunks) :type 'user-error)))) + +(provide 'test-vc-config--gutter-hunk-candidates) +;;; test-vc-config--gutter-hunk-candidates.el ends here diff --git a/tests/test-vc-config--timemachine-commands.el b/tests/test-vc-config--timemachine-commands.el new file mode 100644 index 00000000..36a71695 --- /dev/null +++ b/tests/test-vc-config--timemachine-commands.el @@ -0,0 +1,36 @@ +;;; test-vc-config--timemachine-commands.el --- Tests for git-timemachine command wiring -*- lexical-binding: t -*- + +;;; Commentary: +;; Guards the git-timemachine autoload surface in vc-config.el. The +;; upstream package defines no `git-timemachine-show-selected-revision'; +;; an autoload for it in :commands creates a phantom M-x command that +;; errors after loading the package. The real selector lives in the +;; cj/ namespace. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'vc-config) + +;;; Normal Cases + +(ert-deftest test-vc-timemachine-selected-revision-cj-command-defined () + "Normal: the cj/ selected-revision selector is defined by vc-config." + (should (fboundp 'cj/git-timemachine-show-selected-revision))) + +(ert-deftest test-vc-timemachine-entry-command-defined () + "Normal: the cj/git-timemachine entry command is defined." + (should (commandp 'cj/git-timemachine))) + +;;; Error Cases + +(ert-deftest test-vc-timemachine-no-phantom-package-autoload () + "Error: no autoload exists for a function the package never defines. +An autoload stub for `git-timemachine-show-selected-revision' would +surface in M-x and signal void-function after the package loads." + (should-not (fboundp 'git-timemachine-show-selected-revision))) + +(provide 'test-vc-config--timemachine-commands) +;;; test-vc-config--timemachine-commands.el ends here diff --git a/tests/test-video-audio-recording-group-devices-by-hardware.el b/tests/test-video-audio-recording-group-devices-by-hardware.el deleted file mode 100644 index 2be4982f..00000000 --- a/tests/test-video-audio-recording-group-devices-by-hardware.el +++ /dev/null @@ -1,194 +0,0 @@ -;;; test-video-audio-recording-group-devices-by-hardware.el --- Tests for cj/recording-group-devices-by-hardware -*- lexical-binding: t; -*- - -;;; Commentary: -;; Unit tests for cj/recording-group-devices-by-hardware function. -;; Tests grouping of audio sources by physical hardware device. -;; Critical test: Bluetooth MAC address normalization (colons vs underscores). -;; -;; This function is used by the quick setup command to automatically pair -;; microphone and monitor devices from the same hardware. - -;;; Code: - -(require 'ert) - -;; Stub dependencies before loading the module -(defvar cj/custom-keymap (make-sparse-keymap) - "Stub keymap for testing.") - -;; Now load the actual production module -(require 'video-audio-recording) - -;;; Test Fixtures Helper - -(defun test-load-fixture (filename) - "Load fixture file FILENAME from tests/fixtures directory." - (let ((fixture-path (expand-file-name - (concat "tests/fixtures/" filename) - user-emacs-directory))) - (with-temp-buffer - (insert-file-contents fixture-path) - (buffer-string)))) - -;;; Normal Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-all-types-grouped () - "Test grouping of all three device types (built-in, USB, Bluetooth). -This is the key test validating the complete grouping logic." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (= 3 (length result))) - ;; Check that we have all three device types - (let ((names (mapcar #'car result))) - (should (member "Built-in Audio" names)) - (should (member "Bluetooth Headset" names)) - (should (member "Jabra SPEAK 510 USB" names))) - ;; Verify each device has both mic and monitor - (dolist (device result) - (should (stringp (car device))) ; friendly name - (should (stringp (cadr device))) ; mic device - (should (stringp (cddr device))) ; monitor device - (should-not (string-suffix-p ".monitor" (cadr device))) ; mic not monitor - (should (string-suffix-p ".monitor" (cddr device)))))))) ; monitor has suffix - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-built-in-paired () - "Test that built-in laptop audio devices are correctly paired." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (built-in (assoc "Built-in Audio" result))) - (should built-in) - (should (string-match-p "pci-0000_00_1f" (cadr built-in))) - (should (string-match-p "pci-0000_00_1f" (cddr built-in))) - (should (equal "alsa_input.pci-0000_00_1f.3.analog-stereo" (cadr built-in))) - (should (equal "alsa_output.pci-0000_00_1f.3.analog-stereo.monitor" (cddr built-in))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-usb-paired () - "Test that USB devices (Jabra) are correctly paired." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (jabra (assoc "Jabra SPEAK 510 USB" result))) - (should jabra) - (should (string-match-p "Jabra" (cadr jabra))) - (should (string-match-p "Jabra" (cddr jabra))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-bluetooth-paired () - "Test that Bluetooth devices are correctly paired. -CRITICAL: Tests MAC address normalization (colons in input, underscores in output)." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (bluetooth (assoc "Bluetooth Headset" result))) - (should bluetooth) - ;; Input has colons: bluez_input.00:1B:66:C0:91:6D - (should (equal "bluez_input.00:1B:66:C0:91:6D" (cadr bluetooth))) - ;; Output has underscores: bluez_output.00_1B_66_C0_91_6D.1.monitor - ;; But they should still be grouped together (MAC address normalized) - (should (equal "bluez_output.00_1B_66_C0_91_6D.1.monitor" (cddr bluetooth))))))) - -;;; Boundary Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-empty-returns-empty () - "Test that empty pactl output returns empty list." - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) ""))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-only-inputs-returns-empty () - "Test that only input devices (no monitors) returns empty list. -Devices must have BOTH mic and monitor to be included." - (let ((output (test-load-fixture "pactl-output-inputs-only.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-only-monitors-returns-empty () - "Test that only monitor devices (no inputs) returns empty list." - (let ((output (test-load-fixture "pactl-output-monitors-only.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-single-complete-device () - "Test that single device with both mic and monitor is returned." - (let ((output "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n")) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - (should (equal "Built-in Audio" (caar result))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-mixed-complete-incomplete () - "Test that only devices with BOTH mic and monitor are included. -Incomplete devices (only mic or only monitor) are filtered out." - (let ((output (concat - ;; Complete device (built-in) - "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - "49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - ;; Incomplete: USB mic with no monitor - "100\talsa_input.usb-device.mono-fallback\tPipeWire\ts16le 1ch 16000Hz\tSUSPENDED\n" - ;; Incomplete: Bluetooth monitor with no mic - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - ;; Only the complete built-in device should be returned - (should (= 1 (length result))) - (should (equal "Built-in Audio" (caar result))))))) - -;;; Error Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-malformed-output-returns-empty () - "Test that malformed pactl output returns empty list." - (let ((output (test-load-fixture "pactl-output-malformed.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-unknown-device-type () - "Test that unknown device types get generic 'USB Audio Device' name." - (let ((output (concat - "100\talsa_input.usb-unknown_device-00.analog-stereo\tPipeWire\ts16le 2ch 16000Hz\tSUSPENDED\n" - "99\talsa_output.usb-unknown_device-00.analog-stereo.monitor\tPipeWire\ts16le 2ch 48000Hz\tSUSPENDED\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - ;; Should get generic USB name (not matching Jabra pattern) - (should (equal "USB Audio Device" (caar result))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-bluetooth-mac-case-variations () - "Test that Bluetooth MAC addresses work with different formatting. -Tests the normalization logic handles various MAC address formats." - (let ((output (concat - ;; Input with colons (typical) - "79\tbluez_input.AA:BB:CC:DD:EE:FF\tPipeWire\tfloat32le 1ch 48000Hz\tSUSPENDED\n" - ;; Output with underscores (typical) - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - (should (equal "Bluetooth Headset" (caar result))) - ;; Verify both devices paired despite different MAC formats - (let ((device (car result))) - (should (string-match-p "AA:BB:CC" (cadr device))) - (should (string-match-p "AA_BB_CC" (cddr device)))))))) - -(provide 'test-video-audio-recording-group-devices-by-hardware) -;;; test-video-audio-recording-group-devices-by-hardware.el ends here diff --git a/tests/test-wrap-up--bury-buffers.el b/tests/test-wrap-up--bury-buffers.el new file mode 100644 index 00000000..00df69c7 --- /dev/null +++ b/tests/test-wrap-up--bury-buffers.el @@ -0,0 +1,96 @@ +;;; test-wrap-up--bury-buffers.el --- Tests for cj/bury-buffers -*- lexical-binding: t; -*- + +;;; Commentary: +;; Characterization tests for cj/bury-buffers, which buries the noisy +;; compile-and-shell buffers at the end of startup. +;; +;; Written to pin the buried set while a dead clause was removed. The function +;; tested `(derived-mode-p 'elisp-compile-mode)', and no such mode exists in +;; Emacs -- the real one is `emacs-lisp-compilation-mode', which derives from +;; `compilation-mode' and so was already matched by the clause above it. The +;; clause could never be true, and removing it must not change which buffers +;; get buried. These tests are what makes that claim checkable. +;; +;; Test organization: +;; - Normal Cases: each buried mode is buried; byte-compilation output included +;; - Boundary Cases: an ordinary buffer is left alone; an empty buffer list +;; - Error Cases: a killed buffer in the list does not break the sweep +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'wrap-up) + +;; Required explicitly so each test stands alone. Without these the +;; comint-mode test passed only because ERT runs tests in alphabetical order +;; and an earlier test loaded `compile', which pulls in comint -- so renaming +;; or running that test by itself made it fail with void-function comint-mode. +(require 'comint) +(require 'bytecomp) + +(defmacro test-wrap-up--with-mode-buffer (mode &rest body) + "Create a buffer in MODE, bind it to `buf', run BODY, then kill it." + (declare (indent 1)) + `(let ((buf (generate-new-buffer "*test-bury*"))) + (unwind-protect + (progn + (with-current-buffer buf (funcall ,mode)) + ,@body) + (kill-buffer buf)))) + +;;; Normal Cases + +(ert-deftest test-wrap-up-bury-buffers-buries-compilation () + "Normal: a compilation-mode buffer is buried." + (test-wrap-up--with-mode-buffer #'compilation-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-buries-byte-compilation-output () + "Normal: the real byte-compilation mode is buried. +`emacs-lisp-compilation-mode' derives from `compilation-mode', which is +why the never-matching elisp-compile-mode clause was redundant." + (should (eq 'compilation-mode + (get 'emacs-lisp-compilation-mode 'derived-mode-parent))) + (test-wrap-up--with-mode-buffer #'emacs-lisp-compilation-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-buries-comint () + "Normal: a comint-mode buffer is buried." + (test-wrap-up--with-mode-buffer #'comint-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +;;; Boundary Cases + +(ert-deftest test-wrap-up-bury-buffers-leaves-ordinary-buffer () + "Boundary: a fundamental-mode buffer is not buried." + (test-wrap-up--with-mode-buffer #'fundamental-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-leaves-text-buffer () + "Boundary: an ordinary text-mode buffer is not buried." + (test-wrap-up--with-mode-buffer #'text-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should (eq buf (car (buffer-list)))))) + +;;; Error Cases + +(ert-deftest test-wrap-up-bury-buffers-survives-dead-mode-name () + "Error: the sweep completes even though elisp-compile-mode does not exist. +The removed clause named a mode Emacs has never defined; this pins that +the function still runs cleanly with no such mode anywhere." + (should-not (fboundp 'elisp-compile-mode)) + (should-not (get 'elisp-compile-mode 'derived-mode-parent)) + (cj/bury-buffers)) + +(provide 'test-wrap-up--bury-buffers) +;;; test-wrap-up--bury-buffers.el ends here diff --git a/tests/testutil-calendar-sync.el b/tests/testutil-calendar-sync.el index 2187c56c..60f878d0 100644 --- a/tests/testutil-calendar-sync.el +++ b/tests/testutil-calendar-sync.el @@ -172,6 +172,22 @@ Returns float number of days (positive if date2 > date1)." (t2 (calendar-sync--date-to-time (list (nth 0 date2) (nth 1 date2) (nth 2 date2))))) (/ (float-time (time-subtract t2 t1)) 86400.0))) +(defun test-calendar-sync-time-monthly-anchor (hour minute) + "Return a soon-future date on a day-of-month that every month has. +Walks forward from tomorrow to the first date whose day is 28 or less, then +returns it at HOUR:MINUTE. + +Use this instead of `test-calendar-sync-time-days-from-now' for any test that +asserts a monthly cadence. A relative offset is not a date-independent anchor: +its day-of-month varies with the run date, and a monthly series anchored on the +29th, 30th, or 31st correctly appears only in the months that have that day. A +test asserting roughly one occurrence per month then fails for several days each +month, which is what happened on 2026-07-30." + (let ((days 1)) + (while (> (nth 2 (test-calendar-sync-time-days-from-now days hour minute)) 28) + (setq days (1+ days))) + (test-calendar-sync-time-days-from-now days hour minute))) + (defun test-calendar-sync-wide-range () "Generate wide date range: 90 days past to 365 days future. Returns (start-time end-time) suitable for expansion functions." |