diff options
Diffstat (limited to 'tests')
183 files changed, 10623 insertions, 2669 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--runtime.el b/tests/test-ai-term--runtime.el new file mode 100644 index 00000000..7644e468 --- /dev/null +++ b/tests/test-ai-term--runtime.el @@ -0,0 +1,136 @@ +;;; test-ai-term--runtime.el --- Tests for the ai-term runtime selection -*- lexical-binding: t; -*- + +;;; Commentary: +;; Multi-backend launch: a fresh agent session can run Claude, Codex, or a +;; local model through codex --oss (ollama). The runtime names and launch +;; strings mirror the rulesets bin/ai launcher so the two stay one mental +;; model: "claude", "codex", and "local:<model>". +;; +;; Pure pieces tested here: +;; - `cj/--ai-term-runtime-command' maps a runtime name to the full shell +;; command (agent CLI + the shared opening prompt). +;; - `cj/--ai-term-parse-runtime-lines' parses `ai --print-runtimes' output +;; into (NAME . LABEL) choices. +;; - `cj/--ai-term-runtime-choices' shells out to `ai' at its boundary +;; (mocked here) and falls back to the static list when `ai' is absent. +;; The interactive picker is a thin completing-read wrapper and is not +;; tested (Interactive vs Internal split). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ai-term) + +;;; ------------------------- runtime -> command ------------------------------ + +(ert-deftest test-ai-term-runtime-command-claude-is-agent-command () + "Normal: \"claude\" (and nil) return `cj/ai-term-agent-command' verbatim." + (let ((cj/ai-term-agent-command "claude \"do the thing\"")) + (should (equal (cj/--ai-term-runtime-command "claude") + "claude \"do the thing\"")) + (should (equal (cj/--ai-term-runtime-command nil) + "claude \"do the thing\"")))) + +(ert-deftest test-ai-term-runtime-command-codex-composes-prompt () + "Normal: \"codex\" is the codex CLI plus the shared opening prompt." + (let ((cj/ai-term-agent-prompt "read the protocols")) + (should (equal (cj/--ai-term-runtime-command "codex") + (concat "codex " (shell-quote-argument "read the protocols")))))) + +(ert-deftest test-ai-term-runtime-command-local-model () + "Normal: \"local:<model>\" runs codex --oss against that ollama model. +The model is shell-quoted, and POSIX `shell-quote-argument' backslash-escapes +the colons, so the assertion matches the quoted form." + (let ((cj/ai-term-agent-prompt "read the protocols")) + (let ((cmd (cj/--ai-term-runtime-command "local:gpt-oss:120b"))) + (should (string-prefix-p "codex --oss --local-provider=ollama -m " cmd)) + (should (string-match-p + (regexp-quote (shell-quote-argument "gpt-oss:120b")) cmd)) + (should (string-suffix-p (shell-quote-argument "read the protocols") cmd))))) + +(ert-deftest test-ai-term-runtime-command-boundary-empty-model () + "Boundary: \"local:\" with no model is rejected, not launched half-formed." + (should-error (cj/--ai-term-runtime-command "local:") :type 'user-error)) + +(ert-deftest test-ai-term-runtime-command-error-unknown-runtime () + "Error: an unknown runtime name signals a `user-error' naming it." + (should-error (cj/--ai-term-runtime-command "gemini") :type 'user-error) + (condition-case err + (cj/--ai-term-runtime-command "gemini") + (user-error (should (string-match-p "gemini" (cadr err)))))) + +;;; --------------------------- choice-list parsing --------------------------- + +(ert-deftest test-ai-term-parse-runtime-lines-normal () + "Normal: `ai --print-runtimes' lines parse into (NAME . LABEL) pairs." + (should (equal (cj/--ai-term-parse-runtime-lines + "claude — Claude Code\ncodex — ChatGPT (Codex CLI)\nlocal:gpt-oss:120b — ollama\n") + '(("claude" . "Claude Code") + ("codex" . "ChatGPT (Codex CLI)") + ("local:gpt-oss:120b" . "ollama"))))) + +(ert-deftest test-ai-term-parse-runtime-lines-boundary-junk () + "Boundary: blank lines and lines without a separator are dropped." + (should (equal (cj/--ai-term-parse-runtime-lines + "\nclaude — Claude Code\nwarning: something\n\n") + '(("claude" . "Claude Code"))))) + +(ert-deftest test-ai-term-parse-runtime-lines-boundary-empty () + "Boundary: empty output parses to nil." + (should (null (cj/--ai-term-parse-runtime-lines "")))) + +;;; ------------------------------ choice list -------------------------------- + +(ert-deftest test-ai-term-runtime-choices-uses-ai-launcher () + "Normal: when the `ai' launcher exists, its runtime list is the choice list." + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "ai") "/usr/bin/ai"))) + ((symbol-function 'process-file) + (lambda (_prog _infile buffer _display &rest _args) + (with-current-buffer (cond ((eq buffer t) (current-buffer)) + ((consp buffer) (car buffer)) + (t buffer)) + (insert "claude — Claude Code\nlocal:q — ollama\n")) + 0))) + (should (equal (cj/--ai-term-runtime-choices) + '(("claude" . "Claude Code") ("local:q" . "ollama")))))) + +(ert-deftest test-ai-term-runtime-choices-fallback-without-ai () + "Boundary: with no `ai' launcher, the static claude-first list stands." + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil))) + (let ((choices (cj/--ai-term-runtime-choices))) + (should (equal (caar choices) "claude")) + (should (assoc "codex" choices))))) + +(ert-deftest test-ai-term-runtime-choices-error-ai-fails () + "Error: a nonzero exit from `ai' falls back instead of erroring." + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "ai") "/usr/bin/ai"))) + ((symbol-function 'process-file) (lambda (&rest _) 1))) + (should (equal (caar (cj/--ai-term-runtime-choices)) "claude")))) + +;;; --------------------- launch command takes an override -------------------- + +(ert-deftest test-ai-term-launch-command-runtime-override () + "Normal: an explicit agent command is embedded instead of the default. +The inner command is shell-quoted by the launch builder, so the assertion +matches the quoted form." + (let ((cj/ai-term-agent-command "claude default")) + (let ((cmd (cj/--ai-term-launch-command "/tmp/proj" "codex prompted"))) + (should (string-match-p + (regexp-quote (shell-quote-argument "codex prompted; exec bash")) + cmd)) + (should-not (string-match-p "claude" cmd))))) + +(ert-deftest test-ai-term-launch-command-no-override-falls-back () + "Boundary: without an override the configured agent command is used." + (let ((cj/ai-term-agent-command "claude default")) + (should (string-match-p + (regexp-quote (shell-quote-argument "claude default; exec bash")) + (cj/--ai-term-launch-command "/tmp/proj"))))) + +(provide 'test-ai-term--runtime) +;;; test-ai-term--runtime.el ends here diff --git a/tests/test-ai-term--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 2686b88f..8b13fbb0 100644 --- a/tests/test-auto-dim-config.el +++ b/tests/test-auto-dim-config.el @@ -30,11 +30,309 @@ (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)) + '(org-link org-tag + ;; Document header: #+TITLE:, #+AUTHOR:, #+ARCHIVE: and their values. + org-document-title org-document-info org-document-info-keyword + org-meta-line + ;; Inline markup and blocks. + org-code org-verbatim org-block-begin-line org-block-end-line + ;; Drawers, properties, planning lines. + org-drawer org-special-keyword org-property-value org-date + ;; Tables and the fold indicator. + org-table org-table-row org-ellipsis)) + "Org faces that must flat-dim to the `auto-dim-other-buffers' face. +These carry structure, not status: nothing about them needs to stay +readable in a window the user is not looking at. Excluded on purpose are +`org-todo' and `org-priority' (keyword class -- see the -dim variant test +below) and `org-hide' (needs `auto-dim-other-buffers-hide' so folded text +stays hidden).") + +(defconst test-auto-dim--flat-dimmed-link-faces + '(link link-visited) + "Built-in link faces that must flat-dim, distinct from `org-link'. +They fontify links in help, info, and customize buffers. Both carry +`:underline t', which survives the relative remap, so a dimmed link still +reads as a link.") + +(defconst test-auto-dim--flat-dimmed-superstar-faces + '(org-superstar-header-bullet org-superstar-item org-superstar-first) + "org-superstar faces that must flat-dim. +org-superstar puts its own face ahead of the org face beneath, so a heading +star renders as (org-superstar-header-bullet org-level-1) and wins over the +dimmed org-level-1. Without these, bullets stay lit in an unfocused window +even though every face under them dims. +`org-superstar-leading' is excluded on purpose -- see the test below.") + +(defconst test-auto-dim--hide-class-faces + '(org-hide org-superstar-leading org-indent) + "Faces whose foreground IS the background colour. +That is what makes them invisible. They take `auto-dim-other-buffers-hide', +never the flat dim, which would paint them visible grey.") + +(defconst test-auto-dim--no-foreground-faces + '(bold italic underline) + "Faces that carry no foreground, even through inheritance. +They set weight, slant or underline only, so text wearing them takes its +colour from `default', which is already remapped. They need no entry and +must not gain one, or the alist grows entries that do nothing.") + +(defconst test-auto-dim--keyword-dim-variants + '((org-faces-todo . org-faces-todo-dim) + (org-faces-doing . org-faces-doing-dim) + (org-faces-priority-a . org-faces-priority-a-dim)) + "Sample of keyword faces that must keep dedicated -dim variants.") + +(ert-deftest test-auto-dim-config-org-structure-faces-flat-dim () + "Normal: org heading, link, and tag faces remap to the flat dim face." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--flat-dimmed-org-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers (car (cdr entry)))) + (should (null (cdr (cdr entry))))))) + +(ert-deftest test-auto-dim-config-link-faces-flat-dim () + "Normal: the built-in `link' and `link-visited' faces flat-dim. +Without these, links in help, info, and customize buffers stay lit while +the rest of an unfocused window fades. `org-link' is a separate face and +is covered above." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--flat-dimmed-link-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers (car (cdr entry)))) + (should (null (cdr (cdr entry))))))) + +(ert-deftest test-auto-dim-config-link-underline-survives-the-remap () + "Boundary: the dim face sets no `:underline', so the link cue survives. +A relative remap layers the dim face over the base face, so an underline +the dim face does not specify falls through from `link'. If the theme ever +gives `auto-dim-other-buffers' an `:underline', dimmed links stop looking +like links and this test says so." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (should (eq 'unspecified + (face-attribute 'auto-dim-other-buffers :underline nil nil)))) + +(ert-deftest test-auto-dim-config-superstar-bullets-flat-dim () + "Normal: org-superstar's heading stars and list bullets flat-dim. +They were the last thing left lit in an unfocused org window." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--flat-dimmed-superstar-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers (car (cdr entry)))) + (should (null (cdr (cdr entry))))))) + +(ert-deftest test-auto-dim-config-superstar-leading-uses-hide-face () + "Error: `org-superstar-leading' takes the -hide face, never the flat dim. +Its foreground is the background colour, which is what keeps hidden leading +stars invisible. Flat-dimming it would give them the dim face's visible grey +and reveal stars the user chose to hide. Same contract as `org-hide'." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (should-not (memq 'org-superstar-leading + test-auto-dim--flat-dimmed-superstar-faces)) + (let ((entry (assq 'org-superstar-leading auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers-hide (car (cdr entry)))))) + +(ert-deftest test-auto-dim-config-hide-class-faces-use-hide-face () + "Error: every background-coloured face takes the -hide face. +`org-hide', `org-superstar-leading' and `org-indent' all resolve to the +background colour, which is what keeps folded text, leading stars and indent +prefixes invisible. Flat-dimming any of them reveals what the user hid." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face test-auto-dim--hide-class-faces) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers-hide (car (cdr entry))))))) + +(ert-deftest test-auto-dim-config-no-org-face-left-unmapped () + "Boundary: a fontified org buffer uses no face we forgot to handle. +Four rounds of this bug all had the same shape: a face nobody enumerated, +sitting ahead of a mapped face in a face list and outranking it. This walks +a representative buffer, collects every face it actually uses (including the +`line-prefix' and `wrap-prefix' org-indent hangs its faces on), and fails on +anything that is neither mapped nor deliberately excluded. + +Built-in org only. org-superstar and org-drill are elpa packages, and the +test run has no `package-initialize', so their faces are pinned by name in +the tests above instead." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (require 'org) + (let ((used (make-hash-table :test #'eq)) + (allowed (append test-auto-dim--no-foreground-faces + ;; Keyword class: deliberately unmapped so status stays + ;; readable in an unfocused window. Pinned by + ;; test-auto-dim-config-todo-priority-faces-not-flat-dimmed. + '(org-todo org-priority) + (mapcar #'car auto-dim-other-buffers-affected-faces)))) + (with-temp-buffer + (insert "#+TITLE: T\n#+AUTHOR: A\n\n* H1 :tag:\n** TODO [#A] task\n" + "DEADLINE: <2026-07-10 Fri>\n:PROPERTIES:\n:K: v\n:END:\n" + "Body ~verbatim~ =code= [[https://x.org][link]].\n" + "| a | b |\n|---+---|\n| 1 | 2 |\n" + "#+begin_src sh\necho hi\n#+end_src\n" + "- [X] done item\n") + (org-mode) + (font-lock-ensure) + (let ((p (point-min))) + (while (< p (point-max)) + (dolist (f (let ((v (get-text-property p 'face))) + (if (listp v) v (list v)))) + (when (and f (symbolp f)) (puthash f t used))) + (dolist (prop '(line-prefix wrap-prefix)) + (let ((s (get-text-property p prop))) + (when (stringp s) + (dolist (f (let ((v (get-text-property 0 'face s))) + (if (listp v) v (list v)))) + (when (and f (symbolp f)) (puthash f t used)))))) + (setq p (1+ p))))) + (let (unmapped) + (maphash (lambda (face _v) + (unless (memq face allowed) (push face unmapped))) + used) + (should (equal nil (sort unmapped #'string<)))))) + +(ert-deftest test-auto-dim-config-keyword-faces-keep-dim-variants () + "Boundary: org TODO-keyword faces keep dedicated -dim variants, not flat dim. +Keyword status is scanned across unfocused windows, so it earns a variant; +heading colour does not. Guards the flat-dim change from over-reaching." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (pair test-auto-dim--keyword-dim-variants) + (let ((entry (assq (car pair) auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq (cdr pair) (car (cdr entry))))))) + +(ert-deftest test-auto-dim-config-todo-priority-faces-not-flat-dimmed () + "Boundary: `org-todo' and `org-priority' are never flat-dimmed. +They are keyword class. Dimming them would erase the status colour the +-dim variants exist to preserve, so they stay out of the flat-dim set." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (dolist (face '(org-todo org-priority)) + (should-not (memq face test-auto-dim--flat-dimmed-org-faces)) + (let ((entry (assq face auto-dim-other-buffers-affected-faces))) + (should-not (and entry (eq 'auto-dim-other-buffers (car (cdr entry)))))))) + +(ert-deftest test-auto-dim-config-org-hide-uses-hide-face () + "Boundary: `org-hide' remaps to the -hide face, not the flat dim face. +Flat-dimming it would give folded text a visible foreground." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (let ((entry (assq 'org-hide auto-dim-other-buffers-affected-faces))) + (should entry) + (should (eq 'auto-dim-other-buffers-hide (car (cdr entry)))))) + (ert-deftest test-auto-dim-config-never-dim-dashboard-exempts-dashboard () "Normal: the *dashboard* buffer is exempt from dimming." (skip-unless (file-directory-p test-auto-dim--fork)) diff --git a/tests/test-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--batch-failures.el b/tests/test-calendar-sync--batch-failures.el new file mode 100644 index 00000000..3190be21 --- /dev/null +++ b/tests/test-calendar-sync--batch-failures.el @@ -0,0 +1,47 @@ +;;; test-calendar-sync--batch-failures.el --- Batch failure filter tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; `calendar-sync--batch-failures' picks the rows that did not finish cleanly. +;; The batch runner's exit code is derived from it, and systemd reads that exit +;; code, so the rule is deliberately strict: only `ok' passes. A calendar left +;; `syncing' at the timeout, or one that never started, is a failure -- both +;; states mean the org file on disk is not the calendar's current contents, +;; which is exactly the silent staleness the timer exists to prevent. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(ert-deftest test-calendar-sync-batch-failures-keeps-only-non-ok () + "Normal: an errored calendar is returned and a healthy one is not." + (should (equal (calendar-sync--batch-failures + '(("google" . ok) ("proton" . error))) + '(("proton" . error))))) + +(ert-deftest test-calendar-sync-batch-failures-all-ok-is-empty () + "Normal: a fully successful run reports no failures." + (should (equal (calendar-sync--batch-failures + '(("google" . ok) ("proton" . ok))) + '()))) + +(ert-deftest test-calendar-sync-batch-failures-empty-input-is-empty () + "Boundary: no rows in, no rows out." + (should (equal (calendar-sync--batch-failures '()) '()))) + +(ert-deftest test-calendar-sync-batch-failures-timeout-counts-as-failure () + "Error: a calendar still `syncing' when the wait expired is a failure. +Its org file was not rewritten, so reporting success would hide the staleness." + (should (equal (calendar-sync--batch-failures + '(("google" . ok) ("proton" . syncing))) + '(("proton" . syncing))))) + +(ert-deftest test-calendar-sync-batch-failures-never-counts-as-failure () + "Error: a calendar that never started is a failure, not a skip." + (should (equal (calendar-sync--batch-failures '(("google" . never))) + '(("google" . never))))) + +(provide 'test-calendar-sync--batch-failures) +;;; test-calendar-sync--batch-failures.el ends here diff --git a/tests/test-calendar-sync--batch-report.el b/tests/test-calendar-sync--batch-report.el new file mode 100644 index 00000000..12811200 --- /dev/null +++ b/tests/test-calendar-sync--batch-report.el @@ -0,0 +1,89 @@ +;;; test-calendar-sync--batch-report.el --- Batch report output tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; `calendar-sync-batch-run-and-report' is what the systemd timer runs, so its +;; printed rows are the only record that survives the process. Batch Emacs +;; discards *Messages* at exit, which is where the interactive failure path +;; logs its reason -- so a failed row has to carry its recorded `:last-error' +;; in the printed output or the journal shows "error" with no way to tell a +;; cold gpg-agent from a revoked feed token or a dead network. + +;;; Code: + +(require 'ert) +(require 'cl-lib) ;; cl-letf; calendar-sync pulls it in transitively, don't rely on that + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(defun test-calendar-sync-batch-report--capture (states results) + "Return the report's printed output for STATES and RESULTS. +STATES is an alist of NAME . PLIST seeded into the state table; RESULTS is +what `calendar-sync-batch-run' is stubbed to return, so the report is +exercised without driving a real sync." + (let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + (dolist (entry states) + (puthash (car entry) (cdr entry) calendar-sync--calendar-states)) + (cl-letf (((symbol-function 'calendar-sync-batch-run) + (lambda (&rest _) results))) + (with-output-to-string + (calendar-sync-batch-run-and-report))))) + +;;; Normal + +(ert-deftest test-calendar-sync-batch-report-failed-row-carries-its-reason () + "Normal: a failed calendar prints the recorded `:last-error' reason. +Without it the journal records only \"error\", and the operator cannot tell a +cold gpg-agent from a revoked token without re-running the sync by hand." + (let ((out (test-calendar-sync-batch-report--capture + '(("google" . (:status error :last-error "Decryption failed")) + ("proton" . (:status ok))) + '(("google" . error) ("proton" . ok))))) + (should (string-match-p "google: error" out)) + (should (string-match-p "Decryption failed" out)))) + +(ert-deftest test-calendar-sync-batch-report-ok-row-stays-bare () + "Normal: a calendar that synced prints its status and nothing more. +A stale `:last-error' from an earlier failure must not be appended to a row +that succeeded this run." + (let ((out (test-calendar-sync-batch-report--capture + '(("google" . (:status ok :last-error "Decryption failed"))) + '(("google" . ok))))) + (should (string-match-p "google: ok" out)) + (should-not (string-match-p "Decryption failed" out)))) + +;;; Boundary + +(ert-deftest test-calendar-sync-batch-report-failure-without-reason-still-prints () + "Boundary: a failed row with no recorded reason prints its status alone. +`never' and `syncing' never record a `:last-error', so the reason lookup has +to tolerate nil rather than printing \"nil\" or signalling." + (let ((out (test-calendar-sync-batch-report--capture + '(("google" . (:status syncing))) + '(("google" . syncing) ("absent" . never))))) + (should (string-match-p "google: syncing" out)) + (should (string-match-p "absent: never" out)) + (should-not (string-match-p "nil" out)))) + +;;; Error + +(defun test-calendar-sync-batch-report--exit-code (results) + "Return the report's exit code for RESULTS, discarding its printed output." + (let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + (cl-letf (((symbol-function 'calendar-sync-batch-run) + (lambda (&rest _) results))) + (with-temp-buffer + (let ((standard-output (current-buffer))) + (calendar-sync-batch-run-and-report)))))) + +(ert-deftest test-calendar-sync-batch-report-exit-code-tracks-failures () + "Error: the return value becomes the process exit code, so it stays 1 on any +non-ok row and 0 only when every calendar synced. Appending the reason to the +printed line must not disturb it." + (should (equal 1 (test-calendar-sync-batch-report--exit-code '(("google" . error))))) + (should (equal 1 (test-calendar-sync-batch-report--exit-code + '(("google" . ok) ("proton" . never))))) + (should (equal 0 (test-calendar-sync-batch-report--exit-code '(("google" . ok)))))) + +(provide 'test-calendar-sync--batch-report) +;;; test-calendar-sync--batch-report.el ends here diff --git a/tests/test-calendar-sync--batch-results.el b/tests/test-calendar-sync--batch-results.el new file mode 100644 index 00000000..03ee2aee --- /dev/null +++ b/tests/test-calendar-sync--batch-results.el @@ -0,0 +1,59 @@ +;;; test-calendar-sync--batch-results.el --- Batch result collection tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; `calendar-sync--batch-results' reads the per-calendar state table and +;; returns one (NAME . STATUS) pair per requested calendar. The batch runner +;; turns that into an exit code, so a calendar that never reached the table at +;; all has to read as `never' rather than nil -- a nil status would compare +;; equal to nothing and quietly drop out of the failure count. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(defun test-calendar-sync-batch-results--with-states (states body) + "Run BODY with STATES (an alist of NAME . PLIST) in the state table." + (let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + (dolist (entry states) + (puthash (car entry) (cdr entry) calendar-sync--calendar-states)) + (funcall body))) + +(ert-deftest test-calendar-sync-batch-results-reports-each-status () + "Normal: every requested calendar comes back with its recorded status." + (test-calendar-sync-batch-results--with-states + '(("google" . (:status ok)) + ("proton" . (:status error :last-error "boom"))) + (lambda () + (should (equal (calendar-sync--batch-results '("google" "proton")) + '(("google" . ok) ("proton" . error))))))) + +(ert-deftest test-calendar-sync-batch-results-empty-names-is-empty () + "Boundary: no calendars requested yields no rows, not an error." + (test-calendar-sync-batch-results--with-states + '(("google" . (:status ok))) + (lambda () + (should (equal (calendar-sync--batch-results '()) '()))))) + +(ert-deftest test-calendar-sync-batch-results-missing-calendar-reads-never () + "Error: a calendar absent from the state table reads `never', never nil. +A nil status would drop out of the failure count and report success for a +calendar that never ran." + (test-calendar-sync-batch-results--with-states + '(("google" . (:status ok))) + (lambda () + (should (equal (calendar-sync--batch-results '("google" "absent")) + '(("google" . ok) ("absent" . never))))))) + +(ert-deftest test-calendar-sync-batch-results-preserves-request-order () + "Boundary: rows come back in the order asked for, not hash order." + (test-calendar-sync-batch-results--with-states + '(("a" . (:status ok)) ("b" . (:status ok)) ("c" . (:status ok))) + (lambda () + (should (equal (mapcar #'car (calendar-sync--batch-results '("c" "a" "b"))) + '("c" "a" "b")))))) + +(provide 'test-calendar-sync--batch-results) +;;; test-calendar-sync--batch-results.el ends here diff --git a/tests/test-calendar-sync--batch-wait.el b/tests/test-calendar-sync--batch-wait.el new file mode 100644 index 00000000..7deee5e1 --- /dev/null +++ b/tests/test-calendar-sync--batch-wait.el @@ -0,0 +1,68 @@ +;;; test-calendar-sync--batch-wait.el --- Batch wait-loop tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The sync pipeline is asynchronous end to end: curl runs in one process and +;; the org conversion in a second batch Emacs. Under `emacs --batch' the +;; process exits as soon as the top-level form returns, killing both children +;; mid-flight -- a run that does nothing and reports success. +;; +;; `calendar-sync--batch-wait' is what stops that: it blocks until every +;; calendar has left the `syncing' state, or until the timeout expires. These +;; tests drive it with a stubbed state predicate, so the loop's exit conditions +;; are covered without a live network fetch. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(ert-deftest test-calendar-sync-batch-wait-returns-when-nothing-in-flight () + "Normal: with no calendar syncing the wait returns success immediately." + (let ((polls 0)) + (cl-letf (((symbol-function 'calendar-sync--syncing-p) (lambda (_) nil)) + ((symbol-function 'accept-process-output) + (lambda (&rest _) (setq polls (1+ polls))))) + (should (calendar-sync--batch-wait '("google" "proton") 5)) + (should (= polls 0))))) + +(ert-deftest test-calendar-sync-batch-wait-blocks-until-settled () + "Normal: the wait polls while a sync is in flight and returns once it lands." + (let ((remaining 3) + (polls 0)) + (cl-letf (((symbol-function 'calendar-sync--syncing-p) + (lambda (_) (> remaining 0))) + ((symbol-function 'accept-process-output) + (lambda (&rest _) + (setq polls (1+ polls)) + (setq remaining (1- remaining))))) + (should (calendar-sync--batch-wait '("google") 5)) + (should (= polls 3))))) + +(ert-deftest test-calendar-sync-batch-wait-empty-names-returns-immediately () + "Boundary: no calendars to wait on settles at once." + (let ((polls 0)) + (cl-letf (((symbol-function 'accept-process-output) + (lambda (&rest _) (setq polls (1+ polls))))) + (should (calendar-sync--batch-wait '() 5)) + (should (= polls 0))))) + +(ert-deftest test-calendar-sync-batch-wait-times-out-when-stuck () + "Error: a sync that never settles returns nil once the timeout expires. +Returning nil is what lets the runner exit non-zero instead of reporting a +success it cannot vouch for." + (let ((calendar-sync--batch-poll-seconds 0.01)) + (cl-letf (((symbol-function 'calendar-sync--syncing-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) (lambda (&rest _) nil))) + (should-not (calendar-sync--batch-wait '("google") 0.05))))) + +(ert-deftest test-calendar-sync-batch-wait-zero-timeout-does-not-hang () + "Boundary: a zero timeout returns at once rather than looping forever." + (cl-letf (((symbol-function 'calendar-sync--syncing-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) (lambda (&rest _) nil))) + (should-not (calendar-sync--batch-wait '("google") 0)))) + +(provide 'test-calendar-sync--batch-wait) +;;; test-calendar-sync--batch-wait.el ends here diff --git a/tests/test-calendar-sync--expand-daily.el b/tests/test-calendar-sync--expand-daily.el index 43b93664..0db9f345 100644 --- a/tests/test-calendar-sync--expand-daily.el +++ b/tests/test-calendar-sync--expand-daily.el @@ -176,5 +176,52 @@ (occurrences (calendar-sync--expand-daily base-event rrule range))) (should (= (length occurrences) 5)))) +;;; UNTIL is inclusive (RFC 5545 3.3.10) + +(ert-deftest test-calendar-sync--expand-daily-until-includes-the-until-date () + "Boundary: an occurrence falling ON the UNTIL date is kept. +RFC 5545 3.3.10: UNTIL bounds the recurrence \"in an inclusive manner\", and +when it lines up with the recurrence that date \"becomes the last instance\". +A strict before-comparison drops it, so the last meeting of every bounded +series silently vanishes from the agenda." + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-date (test-calendar-sync-time-date-only 5)) + (base-event (list :summary "Bounded Standup" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range)) + (last-start (plist-get (car (last occurrences)) :start))) + ;; day+1 through day+5 inclusive = 5 occurrences. + (should (= (length occurrences) 5)) + ;; The final occurrence is the UNTIL date itself. + (should (equal (seq-take last-start 3) until-date)))) + +(ert-deftest test-calendar-sync--expand-daily-until-excludes-dates-after-it () + "Boundary: inclusivity stops at UNTIL; the next day is not generated. +Guards the fix against over-correcting into an off-by-one the other way." + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-date (test-calendar-sync-time-date-only 5)) + (day-after (test-calendar-sync-time-date-only 6)) + (base-event (list :summary "Bounded Standup" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range)) + (dates (mapcar (lambda (o) (seq-take (plist-get o :start) 3)) occurrences))) + (should (member until-date dates)) + (should-not (member day-after dates)))) + +(ert-deftest test-calendar-sync--expand-daily-until-on-start-date-yields-one () + "Boundary: UNTIL equal to the start date yields exactly that one occurrence. +The degenerate single-instance series -- a strict comparison returns nothing +at all here, which is the same defect at its smallest." + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-date (test-calendar-sync-time-date-only 1)) + (base-event (list :summary "One Shot" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range))) + (should (= (length occurrences) 1)) + (should (equal (seq-take (plist-get (car occurrences) :start) 3) until-date)))) + (provide 'test-calendar-sync--expand-daily) ;;; test-calendar-sync--expand-daily.el ends here diff --git a/tests/test-calendar-sync--expand-monthly.el b/tests/test-calendar-sync--expand-monthly.el index 3dc1f2dc..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-weekly.el b/tests/test-calendar-sync--expand-weekly.el index a6143bce..0639ca07 100644 --- a/tests/test-calendar-sync--expand-weekly.el +++ b/tests/test-calendar-sync--expand-weekly.el @@ -270,5 +270,33 @@ (should (= (length occurrences) 0))) (test-calendar-sync--expand-weekly-teardown))) +;;; UNTIL is inclusive (RFC 5545 3.3.10) + +(ert-deftest test-calendar-sync--expand-weekly-until-includes-the-until-date () + "Boundary: a weekly occurrence landing ON the UNTIL date is kept. +The weekly loop checks UNTIL in two places -- the outer week-stepping guard +and the per-weekday check inside it -- so it needs its own guard rather than +inheriting the daily one. Fixing the loop without this test left weekly +silently unprotected: reverting the fix failed three daily tests and zero +weekly ones." + (test-calendar-sync--expand-weekly-setup) + (unwind-protect + ;; Omitting :byday makes the series recur on the start date's own weekday, + ;; which anchors UNTIL exactly on an occurrence without hardcoding a date. + (let* ((start-date (test-calendar-sync-time-days-from-now 1 9 0)) + (week-2 (test-calendar-sync-time-date-only 8)) + (until-date (test-calendar-sync-time-date-only 15)) + (week-4 (test-calendar-sync-time-date-only 22)) + (base-event (list :summary "Bounded Weekly" :start start-date)) + (rrule (list :freq 'weekly :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-weekly base-event rrule range)) + (dates (mapcar (lambda (o) (seq-take (plist-get o :start) 3)) occurrences))) + ;; day+1, +8, +15 are consecutive same-weekday dates; UNTIL is the third. + (should (equal dates (list (seq-take start-date 3) week-2 until-date))) + ;; Inclusivity stops at UNTIL -- the following week is not generated. + (should-not (member week-4 dates))) + (test-calendar-sync--expand-weekly-teardown))) + (provide 'test-calendar-sync--expand-weekly) ;;; test-calendar-sync--expand-weekly.el ends here diff --git a/tests/test-calendar-sync--expand-yearly.el b/tests/test-calendar-sync--expand-yearly.el index ad9b8f27..c636e54a 100644 --- a/tests/test-calendar-sync--expand-yearly.el +++ b/tests/test-calendar-sync--expand-yearly.el @@ -175,5 +175,31 @@ (occurrences (calendar-sync--expand-yearly base-event rrule range))) (should (= (length occurrences) 2)))) +;;; BYMONTH + BYDAY (nth weekday) Cases +;; +;; Fixed dates are deterministic here: the expansion range is an explicit +;; parameter, not derived from the current time. + +(ert-deftest test-calendar-sync--expand-yearly-bymonth-byday-nth-weekday () + "Normal: FREQ=YEARLY;BYMONTH=3;BYDAY=2SU tracks the 2nd Sunday of March +each year (the DST clock-change shape), not DTSTART's calendar date." + (let* ((base-event (list :summary "Clocks change" + :start '(2026 3 8 2 0) + :end '(2026 3 8 3 0))) + (rrule (list :freq 'yearly :interval 1 :bymonth 3 :byday '("2SU"))) + (range (list (encode-time 0 0 0 1 1 2026) + (encode-time 0 0 0 31 12 2027))) + (occurrences (calendar-sync--expand-yearly base-event rrule range)) + (days (mapcar (lambda (occ) + (let ((s (plist-get occ :start))) + (list (nth 0 s) (nth 1 s) (nth 2 s)))) + occurrences))) + ;; 2nd Sunday of March: 2026-03-08, 2027-03-14 -- different day-of-month. + (should (equal days '((2026 3 8) (2027 3 14)))) + (dolist (occ occurrences) + (let ((s (plist-get occ :start))) + (should (= 7 (calendar-sync--date-weekday + (list (nth 0 s) (nth 1 s) (nth 2 s))))))))) + (provide 'test-calendar-sync--expand-yearly) ;;; test-calendar-sync--expand-yearly.el ends here diff --git a/tests/test-calendar-sync--format-timestamp.el b/tests/test-calendar-sync--format-timestamp.el index 5b8a6d02..b84e625d 100644 --- a/tests/test-calendar-sync--format-timestamp.el +++ b/tests/test-calendar-sync--format-timestamp.el @@ -56,5 +56,59 @@ ;; start-hour is nil so time-str should be nil (should-not (string-match-p "[0-9][0-9]:[0-9][0-9]-" result)))) +;;; Multi-day spans (org range syntax) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-timed-spans-dates () + "A timed event ending on a later date renders as an org range. +The end DATE used to be discarded and only its time kept, so a four-day +conference produced the same timestamp as a same-day meeting and the agenda +showed it on day one only." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 14 0) '(2026 3 18 15 30)))) + (should (equal result "<2026-03-15 Sun 14:00>--<2026-03-18 Wed 15:30>")))) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-all-day-excludes-dtend () + "An all-day span ends the day before DTEND, which is non-inclusive. +RFC 5545 3.6.1: DTEND is \"the non-inclusive end of the event\", so an +all-day event running Mar 15-17 carries DTEND 2026-03-18. Rendering DTEND +verbatim would add a phantom fourth day." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 nil nil) '(2026 3 18 nil nil)))) + (should (equal result "<2026-03-15 Sun>--<2026-03-17 Tue>")))) + +(ert-deftest test-calendar-sync--format-timestamp-single-all-day-stays-single () + "A one-day all-day event stays a single stamp, never a degenerate range. +Its DTEND is the next day (non-inclusive), so a naive range would turn every +single all-day event into a two-day one -- a worse regression than the +collapse this range support fixes." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 nil nil) '(2026 3 16 nil nil)))) + (should (equal result "<2026-03-15 Sun>")) + (should-not (string-match-p "--" result)))) + +(ert-deftest test-calendar-sync--format-timestamp-same-day-timed-stays-compact () + "A same-day timed event keeps the compact HH:MM-HH:MM form, not a range. +Guards the common case against the range branch." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 14 0) '(2026 3 15 15 30)))) + (should (equal result "<2026-03-15 Sun 14:00-15:30>")) + (should-not (string-match-p "--" result)))) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-all-day-two-days () + "Boundary: the shortest real all-day span (two days) renders as a range. +DTEND 2026-03-17 means the event covers Mar 15-16; one day fewer and it +collapses to the single-stamp case above." + (let ((result (calendar-sync--format-timestamp + '(2026 3 15 nil nil) '(2026 3 17 nil nil)))) + (should (equal result "<2026-03-15 Sun>--<2026-03-16 Mon>")))) + +(ert-deftest test-calendar-sync--format-timestamp-multi-day-span-crosses-month () + "Boundary: an all-day span crossing a month boundary decrements correctly. +DTEND 2026-04-01 means the event's last day is 2026-03-31, which exercises +the borrow in `calendar-sync--add-days'." + (let ((result (calendar-sync--format-timestamp + '(2026 3 30 nil nil) '(2026 4 1 nil nil)))) + (should (equal result "<2026-03-30 Mon>--<2026-03-31 Tue>")))) + (provide 'test-calendar-sync--format-timestamp) ;;; test-calendar-sync--format-timestamp.el ends here diff --git a/tests/test-calendar-sync--get-exdates.el b/tests/test-calendar-sync--get-exdates.el index 3283bbae..981a1857 100644 --- a/tests/test-calendar-sync--get-exdates.el +++ b/tests/test-calendar-sync--get-exdates.el @@ -103,6 +103,35 @@ END:VEVENT")) (should (= 1 (length result))) (should (string= "20260210T130000" (car result)))))) +(ert-deftest test-calendar-sync--get-exdates-boundary-comma-separated-returns-all () + "Boundary: comma-separated EXDATE values on one line are each returned. +RFC 5545 permits multiple datetimes per EXDATE line; missing the split +drops those exclusions, so cancelled instances resurrect in the agenda." + (let ((event "BEGIN:VEVENT +DTSTART:20260203T130000 +RRULE:FREQ=WEEKLY;BYDAY=TU +EXDATE:20260210T130000,20260217T130000,20260224T130000 +SUMMARY:Weekly Meeting +END:VEVENT")) + (let ((result (calendar-sync--get-exdates event))) + (should (= 3 (length result))) + (should (member "20260210T130000" result)) + (should (member "20260217T130000" result)) + (should (member "20260224T130000" result))))) + +(ert-deftest test-calendar-sync--get-exdates-boundary-comma-separated-with-tzid () + "Boundary: comma-separated EXDATE values sharing a TZID are each returned." + (let ((event "BEGIN:VEVENT +DTSTART;TZID=America/New_York:20260203T130000 +RRULE:FREQ=WEEKLY;BYDAY=TU +EXDATE;TZID=America/New_York:20260210T130000,20260217T130000 +SUMMARY:Weekly Meeting +END:VEVENT")) + (let ((result (calendar-sync--get-exdates event))) + (should (= 2 (length result))) + (should (member "20260210T130000" result)) + (should (member "20260217T130000" result))))) + ;;; Error Cases (ert-deftest test-calendar-sync--get-exdates-error-empty-string-returns-nil () diff --git a/tests/test-calendar-sync--nth-weekday-of-month.el b/tests/test-calendar-sync--nth-weekday-of-month.el new file mode 100644 index 00000000..afb0bd35 --- /dev/null +++ b/tests/test-calendar-sync--nth-weekday-of-month.el @@ -0,0 +1,67 @@ +;;; test-calendar-sync--nth-weekday-of-month.el --- Tests for calendar-sync--nth-weekday-of-month -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the nth-weekday-of-month helper backing monthly/yearly BYDAY +;; expansion. Fixed dates are safe here: the function is pure calendar +;; arithmetic with no relation to the current time. + +;;; Code: + +(require 'ert) +(require 'calendar-sync) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-second-wednesday () + "Normal: 2nd Wednesday of Jan 2026 is the 14th." + ;; Jan 2026: Jan 1 is a Thursday; Wednesdays fall on 7, 14, 21, 28. + (should (= (calendar-sync--nth-weekday-of-month 2026 1 3 2) 14))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-first-monday () + "Normal: 1st Monday of Feb 2026 is the 2nd." + ;; Feb 2026: Feb 1 is a Sunday; Mondays fall on 2, 9, 16, 23. + (should (= (calendar-sync--nth-weekday-of-month 2026 2 1 1) 2))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-last-tuesday () + "Normal: last Tuesday of Mar 2026 is the 31st (negative ordinal)." + ;; Mar 2026: Tuesdays fall on 3, 10, 17, 24, 31. + (should (= (calendar-sync--nth-weekday-of-month 2026 3 2 -1) 31))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-normal-second-to-last-friday () + "Normal: -2 ordinal picks the second-to-last Friday." + ;; May 2026: Fridays fall on 1, 8, 15, 22, 29. + (should (= (calendar-sync--nth-weekday-of-month 2026 5 5 -2) 22))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-fifth-occurrence-exists () + "Boundary: 5th Friday exists in May 2026." + (should (= (calendar-sync--nth-weekday-of-month 2026 5 5 5) 29))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-fifth-occurrence-missing () + "Boundary: 5th Wednesday of Feb 2026 does not exist -- returns nil." + ;; Feb 2026 has four Wednesdays (4, 11, 18, 25). + (should (null (calendar-sync--nth-weekday-of-month 2026 2 3 5)))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-first-day-is-target () + "Boundary: the 1st of the month itself is the 1st occurrence." + ;; Apr 2026: Apr 1 is a Wednesday. + (should (= (calendar-sync--nth-weekday-of-month 2026 4 3 1) 1))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-boundary-leap-february () + "Boundary: leap-year February (2028) handled -- last Tuesday is the 29th." + ;; Feb 2028: Feb 29 exists and is a Tuesday. + (should (= (calendar-sync--nth-weekday-of-month 2028 2 2 -1) 29))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--nth-weekday-of-month-error-zero-ordinal-nil () + "Error: ordinal 0 is meaningless -- returns nil." + (should (null (calendar-sync--nth-weekday-of-month 2026 1 3 0)))) + +(ert-deftest test-calendar-sync--nth-weekday-of-month-error-out-of-range-negative-nil () + "Error: -6th occurrence never exists in a month -- returns nil." + (should (null (calendar-sync--nth-weekday-of-month 2026 1 3 -6)))) + +(provide 'test-calendar-sync--nth-weekday-of-month) +;;; test-calendar-sync--nth-weekday-of-month.el ends here diff --git a/tests/test-calendar-sync--parse-byday-entry.el b/tests/test-calendar-sync--parse-byday-entry.el new file mode 100644 index 00000000..4a9b4ef5 --- /dev/null +++ b/tests/test-calendar-sync--parse-byday-entry.el @@ -0,0 +1,41 @@ +;;; test-calendar-sync--parse-byday-entry.el --- Tests for calendar-sync--parse-byday-entry -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for parsing a single RRULE BYDAY entry ("2WE", "-1TU", "SU") into +;; an (ordinal . weekday-number) cons. Ordinal is nil for a bare weekday. + +;;; Code: + +(require 'ert) +(require 'calendar-sync) + +;;; Normal Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-positive-ordinal () + "Normal: \"2WE\" parses to ordinal 2, Wednesday (3)." + (should (equal (calendar-sync--parse-byday-entry "2WE") '(2 . 3)))) + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-negative-ordinal () + "Normal: \"-1TU\" parses to ordinal -1, Tuesday (2)." + (should (equal (calendar-sync--parse-byday-entry "-1TU") '(-1 . 2)))) + +(ert-deftest test-calendar-sync--parse-byday-entry-normal-bare-weekday () + "Normal: \"SU\" parses to nil ordinal, Sunday (7)." + (should (equal (calendar-sync--parse-byday-entry "SU") '(nil . 7)))) + +;;; Boundary Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-boundary-double-digit-ordinal () + "Boundary: \"53MO\" (yearly-scale ordinal) parses without truncation." + (should (equal (calendar-sync--parse-byday-entry "53MO") '(53 . 1)))) + +;;; Error Cases + +(ert-deftest test-calendar-sync--parse-byday-entry-error-garbage-nil () + "Error: an unrecognizable entry returns nil." + (should (null (calendar-sync--parse-byday-entry "XX"))) + (should (null (calendar-sync--parse-byday-entry ""))) + (should (null (calendar-sync--parse-byday-entry nil)))) + +(provide 'test-calendar-sync--parse-byday-entry) +;;; test-calendar-sync--parse-byday-entry.el ends here diff --git a/tests/test-calendar-sync--parse-event.el b/tests/test-calendar-sync--parse-event.el index 9c343db2..b3f58ba2 100644 --- a/tests/test-calendar-sync--parse-event.el +++ b/tests/test-calendar-sync--parse-event.el @@ -78,5 +78,37 @@ (let ((vevent "BEGIN:VEVENT\nSUMMARY:Orphan\nEND:VEVENT")) (should (null (calendar-sync--parse-event vevent))))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--parse-event-error-cancelled-returns-nil () + "Error: a STATUS:CANCELLED event returns nil -- cancelled events don't render." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Cancelled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:CANCELLED\n" + "END:VEVENT"))) + (should (null (calendar-sync--parse-event vevent))))) + +(ert-deftest test-calendar-sync--parse-event-boundary-cancelled-case-insensitive () + "Boundary: STATUS value matching is case-insensitive." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Cancelled Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:Cancelled\n" + "END:VEVENT"))) + (should (null (calendar-sync--parse-event vevent))))) + +(ert-deftest test-calendar-sync--parse-event-normal-confirmed-still-parses () + "Normal: STATUS:CONFIRMED events still parse." + (let* ((start (test-calendar-sync-time-days-from-now 5 14 0)) + (vevent (concat "BEGIN:VEVENT\n" + "SUMMARY:Confirmed Meeting\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "STATUS:CONFIRMED\n" + "END:VEVENT"))) + (should (calendar-sync--parse-event vevent)))) + (provide 'test-calendar-sync--parse-event) ;;; test-calendar-sync--parse-event.el ends here diff --git a/tests/test-calendar-sync--parse-exception-event.el b/tests/test-calendar-sync--parse-exception-event.el index a26a7418..1c9411f3 100644 --- a/tests/test-calendar-sync--parse-exception-event.el +++ b/tests/test-calendar-sync--parse-exception-event.el @@ -82,5 +82,33 @@ than a half-built plist." "END:VEVENT"))) (should-not (calendar-sync--parse-exception-event event)))) +;;; STATUS:CANCELLED Cases + +(ert-deftest test-calendar-sync--parse-exception-event-normal-cancelled-flag () + "Normal: a STATUS:CANCELLED override carries :cancelled t, so the +matching occurrence can be removed rather than overridden." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (event (concat "BEGIN:VEVENT\n" + "UID:override@google.com\n" + "RECURRENCE-ID:20260203T090000Z\n" + "SUMMARY:Craig / Ryan\n" + "STATUS:CANCELLED\n" + "DTSTART:" (test-calendar-sync-ics-datetime start) "\n" + "DTEND:" (test-calendar-sync-ics-datetime end) "\n" + "END:VEVENT")) + (plist (calendar-sync--parse-exception-event event))) + (should plist) + (should (plist-get plist :cancelled)))) + +(ert-deftest test-calendar-sync--parse-exception-event-boundary-no-status-not-cancelled () + "Boundary: an override without STATUS is not cancelled." + (let* ((start (test-calendar-sync-time-days-from-now 7 10 0)) + (end (test-calendar-sync-time-days-from-now 7 11 0)) + (plist (calendar-sync--parse-exception-event + (test-cs-parse-exc--override-event start end)))) + (should plist) + (should-not (plist-get plist :cancelled)))) + (provide 'test-calendar-sync--parse-exception-event) ;;; test-calendar-sync--parse-exception-event.el ends here diff --git a/tests/test-calendar-sync--parse-rrule.el b/tests/test-calendar-sync--parse-rrule.el index 099e4e44..2668c1ac 100644 --- a/tests/test-calendar-sync--parse-rrule.el +++ b/tests/test-calendar-sync--parse-rrule.el @@ -206,5 +206,26 @@ (should (= (plist-get result :count) 10))) (test-calendar-sync--parse-rrule-teardown))) +;;; BYSETPOS / BYMONTH Cases + +(ert-deftest test-calendar-sync--parse-rrule-normal-bysetpos-returns-number () + "Normal: BYSETPOS parses to a number (Proton emits BYDAY=SU;BYSETPOS=2)." + (let ((result (calendar-sync--parse-rrule "FREQ=MONTHLY;BYDAY=SU;BYSETPOS=2"))) + (should (eq (plist-get result :freq) 'monthly)) + (should (equal (plist-get result :byday) '("SU"))) + (should (= (plist-get result :bysetpos) 2)))) + +(ert-deftest test-calendar-sync--parse-rrule-normal-bymonth-returns-number () + "Normal: BYMONTH parses to a number (yearly nth-weekday rules carry it)." + (let ((result (calendar-sync--parse-rrule "FREQ=YEARLY;BYMONTH=3;BYDAY=2SU"))) + (should (eq (plist-get result :freq) 'yearly)) + (should (= (plist-get result :bymonth) 3)) + (should (equal (plist-get result :byday) '("2SU"))))) + +(ert-deftest test-calendar-sync--parse-rrule-boundary-negative-bysetpos () + "Boundary: negative BYSETPOS (last matching day) parses." + (let ((result (calendar-sync--parse-rrule "FREQ=MONTHLY;BYDAY=FR;BYSETPOS=-1"))) + (should (= (plist-get result :bysetpos) -1)))) + (provide 'test-calendar-sync--parse-rrule) ;;; test-calendar-sync--parse-rrule.el ends here diff --git a/tests/test-calendar-sync--sync-dispatch.el b/tests/test-calendar-sync--sync-dispatch.el index 22deeef0..9b12b167 100644 --- a/tests/test-calendar-sync--sync-dispatch.el +++ b/tests/test-calendar-sync--sync-dispatch.el @@ -77,5 +77,44 @@ than crashing." (should (equal (list cal) ics-calls)) (should (null api-calls))))) +(ert-deftest test-calendar-sync--sync-dispatch-error-leaf-signal-is-contained () + "Error: a syncer that signals marks the calendar failed instead of propagating. + +Resolving a `:secret-host' feed reads authinfo.gpg, and a cold gpg-agent makes +that signal a `file-error' before any process starts — so the failure arrives +synchronously, where the async callbacks that normally record a failure never +run." + (let ((failed '()) + (calendar-sync--calendar-states (make-hash-table :test 'equal))) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (_) (signal 'file-error '("Decryption failed")))) + ((symbol-function 'calendar-sync--mark-sync-failed) + (lambda (name reason) (push (cons name reason) failed)))) + (calendar-sync--sync-calendar + '(:name "google" :url "https://x/y.ics" :file "/tmp/c.org")) + (should (equal "google" (car (car failed))))))) + +(ert-deftest test-calendar-sync--sync-all-continues-past-a-failing-calendar () + "Error: one calendar's synchronous failure does not stop the ones after it. + +This is the whole cost of leaving the signal uncontained: on a machine whose +feeds resolve through authinfo, the first calendar's decryption error aborted +the entire run, so calendars that would have synced fine never got the chance." + (let ((synced '()) + (calendar-sync--calendar-states (make-hash-table :test 'equal)) + (calendar-sync-calendars + '((:name "bad" :url "https://x/a.ics" :file "/tmp/a.org") + (:name "good" :url "https://x/b.ics" :file "/tmp/b.org")))) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) + (if (equal (plist-get cal :name) "bad") + (signal 'file-error '("Decryption failed")) + (push (plist-get cal :name) synced)))) + ((symbol-function 'calendar-sync--mark-sync-failed) + (lambda (&rest _) nil)) + ((symbol-function 'message) (lambda (&rest _) nil))) + (calendar-sync--sync-all-calendars) + (should (equal '("good") synced))))) + (provide 'test-calendar-sync--sync-dispatch) ;;; test-calendar-sync--sync-dispatch.el ends here diff --git a/tests/test-calendar-sync--syncing-p.el b/tests/test-calendar-sync--syncing-p.el index b346bf77..df8bcd52 100644 --- a/tests/test-calendar-sync--syncing-p.el +++ b/tests/test-calendar-sync--syncing-p.el @@ -4,81 +4,111 @@ ;; Unit tests for `calendar-sync--syncing-p' (the per-calendar in-flight check ;; that lets the dispatcher skip an overlapping timer tick) and for the ;; load-state sanitize that clears a stale `syncing' status in a fresh process. +;; +;; Every test runs inside `test-cs-syncing--with-fresh-state', which let-binds +;; a private state hash. These tests previously cleared the module's global +;; hash on entry and left whatever they wrote in it on exit, which leaked: +;; `...-sync-calendar-skips-when-in-flight' marks "proton" as syncing to +;; exercise the guard, and `test-calendar-sync--sync-dispatch-normal-ics-fetcher' +;; in the sibling dispatch file dispatches a calendar also named "proton". +;; ERT runs them in that order, so the leftover in-flight status made the +;; dispatch a no-op and the sibling failed -- but only when the calendar-sync +;; files ran in one process. `make test' runs each file separately and the +;; editor hook skipped this family for being over its file cap, so nothing +;; caught it. Let-binding is what the sibling files already do +;; (test-calendar-sync.el, test-calendar-sync-async-worker.el); this file was +;; the odd one out. ;;; Code: (require 'ert) (require 'calendar-sync) -(defun test-cs-syncing--reset () - "Clear the module's per-calendar state hash." - (clrhash calendar-sync--calendar-states)) +(defmacro test-cs-syncing--with-fresh-state (&rest body) + "Run BODY with a private, empty per-calendar state hash. +Let-bound rather than cleared in place, so nothing this test writes can +reach a later test." + (declare (indent 0)) + `(let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + ,@body)) ;;; calendar-sync--syncing-p (ert-deftest test-calendar-sync--syncing-p-normal-true-when-syncing () "Normal: a calendar whose status is `syncing' reads as in-flight." - (test-cs-syncing--reset) - (calendar-sync--set-calendar-state "google" '(:status syncing)) - (should (calendar-sync--syncing-p "google"))) + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "google" '(:status syncing)) + (should (calendar-sync--syncing-p "google")))) (ert-deftest test-calendar-sync--syncing-p-boundary-nil-when-no-state () "Boundary: a calendar with no recorded state is not in-flight." - (test-cs-syncing--reset) - (should-not (calendar-sync--syncing-p "never-seen"))) + (test-cs-syncing--with-fresh-state + (should-not (calendar-sync--syncing-p "never-seen")))) (ert-deftest test-calendar-sync--syncing-p-error-nil-for-terminal-status () "Error: a terminal status (ok / error) is not in-flight." - (test-cs-syncing--reset) - (calendar-sync--set-calendar-state "google" '(:status ok)) - (should-not (calendar-sync--syncing-p "google")) - (calendar-sync--set-calendar-state "proton" '(:status error)) - (should-not (calendar-sync--syncing-p "proton"))) + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "google" '(:status ok)) + (should-not (calendar-sync--syncing-p "google")) + (calendar-sync--set-calendar-state "proton" '(:status error)) + (should-not (calendar-sync--syncing-p "proton")))) ;;; Dispatcher guard: an in-flight calendar skips both leaf syncers (ert-deftest test-calendar-sync--sync-calendar-skips-when-in-flight () "Normal: `calendar-sync--sync-calendar' does not launch a second sync for a calendar already marked syncing, so an overlapping timer tick is a no-op." - (test-cs-syncing--reset) - (let ((api-calls '()) (ics-calls '())) - (cl-letf (((symbol-function 'calendar-sync--sync-calendar-api) - (lambda (cal) (push cal api-calls))) - ((symbol-function 'calendar-sync--sync-calendar-ics) - (lambda (cal) (push cal ics-calls)))) - (calendar-sync--set-calendar-state "proton" '(:status syncing)) - (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" - :file "/tmp/c.org")) - (should (null api-calls)) - (should (null ics-calls))))) + (test-cs-syncing--with-fresh-state + (let ((api-calls '()) (ics-calls '())) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-api) + (lambda (cal) (push cal api-calls))) + ((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) (push cal ics-calls)))) + (calendar-sync--set-calendar-state "proton" '(:status syncing)) + (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" + :file "/tmp/c.org")) + (should (null api-calls)) + (should (null ics-calls)))))) (ert-deftest test-calendar-sync--sync-calendar-dispatches-when-idle () "Boundary: an idle calendar (no in-flight status) still dispatches normally." - (test-cs-syncing--reset) - (let ((ics-calls '())) - (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) - (lambda (cal) (push cal ics-calls)))) - (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" - :file "/tmp/c.org")) - (should (= 1 (length ics-calls)))))) + (test-cs-syncing--with-fresh-state + (let ((ics-calls '())) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) (push cal ics-calls)))) + (calendar-sync--sync-calendar '(:name "proton" :url "https://x/y.ics" + :file "/tmp/c.org")) + (should (= 1 (length ics-calls))))))) + +;;; Isolation guard + +(ert-deftest test-calendar-sync--syncing-state-does-not-leak () + "Error: state written inside the macro is gone once it returns. +Pins the isolation itself. Without it a test marking a calendar syncing +leaves that status set for every later test in the same process, which is +exactly what broke the sibling dispatch test." + (test-cs-syncing--with-fresh-state + (calendar-sync--set-calendar-state "leak-probe" '(:status syncing)) + (should (calendar-sync--syncing-p "leak-probe"))) + (should-not (calendar-sync--syncing-p "leak-probe"))) ;;; load-state sanitize: a persisted `syncing' status is cleared on load (ert-deftest test-calendar-sync--load-state-clears-stale-syncing () "Error: a `syncing' status persisted before a crash is reset on load, so the in-flight guard cannot skip that calendar forever in the new session." - (test-cs-syncing--reset) - (let* ((dir (make-temp-file "cs-state-" t)) - (calendar-sync--state-file (expand-file-name "state.el" dir))) - (unwind-protect - (progn - (with-temp-file calendar-sync--state-file - (prin1 '((timezone-offset . nil) - (calendar-states . (("google" . (:status syncing))))) - (current-buffer))) - (calendar-sync--load-state) - (should-not (calendar-sync--syncing-p "google"))) - (delete-directory dir t)))) + (test-cs-syncing--with-fresh-state + (let* ((dir (make-temp-file "cs-state-" t)) + (calendar-sync--state-file (expand-file-name "state.el" dir))) + (unwind-protect + (progn + (with-temp-file calendar-sync--state-file + (prin1 '((timezone-offset . nil) + (calendar-states . (("google" . (:status syncing))))) + (current-buffer))) + (calendar-sync--load-state) + (should-not (calendar-sync--syncing-p "google"))) + (delete-directory dir t))))) (provide 'test-calendar-sync--syncing-p) ;;; test-calendar-sync--syncing-p.el ends here diff --git a/tests/test-calendar-sync-properties.el b/tests/test-calendar-sync-properties.el index c25bb99f..0b01cbd9 100644 --- a/tests/test-calendar-sync-properties.el +++ b/tests/test-calendar-sync-properties.el @@ -77,12 +77,21 @@ For any COUNT value N, expansion never produces more than N occurrences." ;;; Property 2: UNTIL Boundary +;; These two asserted the wrong invariant until 2026-07-16: they required every +;; occurrence to fall strictly BEFORE UNTIL, which is the exclusive reading RFC +;; 5545 3.3.10 contradicts ("bounds the recurrence rule in an inclusive manner"; +;; a UNTIL synchronized with the recurrence "becomes the last instance"). They +;; were written against the expansion loop's strict `before-date-p' guard and so +;; pinned the very defect that dropped the last instance of every bounded series. +;; The property is on-or-before; the upper bound is what UNTIL is for. + (ert-deftest test-calendar-sync-property-until-bounds-daily () - "Property: No daily occurrence starts on or after UNTIL date." + "Property: no daily occurrence starts after the UNTIL date. +UNTIL is an inclusive bound (RFC 5545 3.3.10), so landing exactly on it is +correct and only a later date violates the property." (dotimes (_ test-calendar-sync-property-trials) (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) (until-days (+ 10 (random 60))) - ;; UNTIL must be date-only (3 elements) for calendar-sync--before-date-p (until-date (test-calendar-sync-time-date-only until-days)) (base-event (list :summary "Until Test" :start start-date)) (rrule (list :freq 'daily :interval 1 :until until-date)) @@ -90,16 +99,35 @@ For any COUNT value N, expansion never produces more than N occurrences." (occurrences (calendar-sync--expand-daily base-event rrule range))) (dolist (occ occurrences) (let ((occ-start (plist-get occ :start))) - (should (calendar-sync--before-date-p + (should (calendar-sync--date-on-or-before-p (list (nth 0 occ-start) (nth 1 occ-start) (nth 2 occ-start)) until-date))))))) +(ert-deftest test-calendar-sync-property-until-bounds-daily-reaches-until () + "Property: a daily series stepping by one day always reaches its UNTIL date. +With interval 1 the recurrence is synchronized with any UNTIL, so the last +instance must be UNTIL itself. This is the half the old exclusive property +could never have caught -- it only bounded from above, so silently dropping +the final occurrence satisfied it." + (dotimes (_ test-calendar-sync-property-trials) + (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) + (until-days (+ 10 (random 60))) + (until-date (test-calendar-sync-time-date-only until-days)) + (base-event (list :summary "Until Test" :start start-date)) + (rrule (list :freq 'daily :interval 1 :until until-date)) + (range (test-calendar-sync-wide-range)) + (occurrences (calendar-sync--expand-daily base-event rrule range)) + (last-start (plist-get (car (last occurrences)) :start))) + (should occurrences) + (should (equal (seq-take last-start 3) until-date))))) + (ert-deftest test-calendar-sync-property-until-bounds-weekly () - "Property: No weekly occurrence starts on or after UNTIL date." + "Property: no weekly occurrence starts after the UNTIL date. +UNTIL is an inclusive bound (RFC 5545 3.3.10), so landing exactly on it is +correct and only a later date violates the property." (dotimes (_ test-calendar-sync-property-trials) (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) (until-days (+ 14 (random 60))) - ;; UNTIL must be date-only (3 elements) for calendar-sync--before-date-p (until-date (test-calendar-sync-time-date-only until-days)) (weekdays (test-calendar-sync-random-weekday-subset)) (base-event (list :summary "Until Test" :start start-date)) @@ -108,7 +136,7 @@ For any COUNT value N, expansion never produces more than N occurrences." (occurrences (calendar-sync--expand-weekly base-event rrule range))) (dolist (occ occurrences) (let ((occ-start (plist-get occ :start))) - (should (calendar-sync--before-date-p + (should (calendar-sync--date-on-or-before-p (list (nth 0 occ-start) (nth 1 occ-start) (nth 2 occ-start)) until-date))))))) diff --git a/tests/test-calendar-sync-run.bats b/tests/test-calendar-sync-run.bats new file mode 100644 index 00000000..da817060 --- /dev/null +++ b/tests/test-calendar-sync-run.bats @@ -0,0 +1,116 @@ +#!/usr/bin/env bats +# Tests for scripts/calendar-sync-run — the batch syncer behind the timer. +# +# The elisp tests cover the wait loop and the result tally with the state +# predicate stubbed. What only a shell test can cover is the thing that makes +# the whole script necessary: the sync pipeline is asynchronous end to end +# (curl in one process, the org conversion in a second batch Emacs), and a +# batch Emacs exits as soon as its top-level form returns. A version that +# launches the fetch and returns would exit zero, write nothing, and look +# exactly like a success. Every assertion here that checks the output file +# exists is really asserting that the script waited. +# +# Isolation rules, mirroring test-agenda-render-cache.bats: +# +# EMACS_D points at THIS checkout, so a broken tree cannot pass by running +# the installed config's elisp. +# +# CALENDAR_SYNC_CONFIG and CALENDAR_SYNC_STATE point at fixtures, so the run +# neither reads Craig's real feed URLs nor writes his persisted sync state. +# +# The feed is a file:// URL served to the script's own curl. That keeps the +# test hermetic -- no network, no live calendar -- while still exercising the +# real fetch path rather than a stub. + +setup() { + SCRIPT="${BATS_TEST_DIRNAME}/../scripts/calendar-sync-run" + export EMACS_D="${BATS_TEST_DIRNAME}/.." + export CALENDAR_SYNC_STATE="${BATS_TEST_TMPDIR}/state.el" + export CALENDAR_SYNC_TIMEOUT=120 + + OUT="${BATS_TEST_TMPDIR}/testcal.org" + ICS="${BATS_TEST_TMPDIR}/feed.ics" + TODAY="$(date +%Y%m%d)" + + cat > "$ICS" <<-EOF + BEGIN:VCALENDAR + VERSION:2.0 + PRODID:-//bats//test//EN + BEGIN:VEVENT + UID:bats-fixture-1 + DTSTART:${TODAY}T140000Z + DTEND:${TODAY}T150000Z + SUMMARY:Batch Fixture Event + END:VEVENT + END:VCALENDAR + EOF + + write_config "file://${ICS}" +} + +# The calendar list is normally private config; the test writes its own so the +# feed URL is a local file and the output lands in the temp dir. +write_config() { + export CALENDAR_SYNC_CONFIG="${BATS_TEST_TMPDIR}/config.el" + cat > "$CALENDAR_SYNC_CONFIG" <<-EOF + (setq calendar-sync-calendars + (list (list :name "testcal" :url "$1" :file "${OUT}"))) + EOF +} + +@test "the script is executable" { + [ -x "$SCRIPT" ] +} + +@test "waits for the async pipeline and writes the org file" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # The file existing at all is the assertion: it is written by a grandchild + # process, so a script that did not wait would have exited before this. + [ -f "$OUT" ] + grep -q "Batch Fixture Event" "$OUT" +} + +@test "reports the calendar and its status on stdout" { + run "$SCRIPT" + [ "$status" -eq 0 ] + [[ "$output" == *"testcal: ok"* ]] +} + +@test "a failed fetch exits non-zero so systemd records it" { + write_config "file://${BATS_TEST_TMPDIR}/does-not-exist.ics" + run "$SCRIPT" + [ "$status" -ne 0 ] + [ ! -f "$OUT" ] +} + +@test "a failed fetch names the calendar rather than failing silently" { + write_config "file://${BATS_TEST_TMPDIR}/does-not-exist.ics" + run "$SCRIPT" + [[ "$output" == *"testcal"* ]] + [[ "$output" != *"testcal: ok"* ]] +} + +@test "a failed fetch prints why, not just that it failed" { + # The interactive path logs the reason to *Messages*, which batch Emacs + # discards at exit. Without the reason on stdout the journal shows only + # "error" -- no way to tell a cold gpg-agent from a revoked feed token. + write_config "file://${BATS_TEST_TMPDIR}/does-not-exist.ics" + run "$SCRIPT" + [[ "$output" == *"testcal: error"* ]] + [[ "$output" == *"Fetch failed"* ]] +} + +@test "refuses to run against a checkout with no modules directory" { + EMACS_D="${BATS_TEST_TMPDIR}/empty" run "$SCRIPT" + [ "$status" -ne 0 ] + [[ "$output" == *"no modules directory"* ]] +} + +@test "does not write the real session's sync state" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # The state override is honoured, so a timer run cannot corrupt or race + # the interactive session's persisted state. + [ -f "$CALENDAR_SYNC_STATE" ] +} diff --git a/tests/test-calendar-sync-source-fetch-sentinel.el b/tests/test-calendar-sync-source-fetch-sentinel.el new file mode 100644 index 00000000..0b7ba1cf --- /dev/null +++ b/tests/test-calendar-sync-source-fetch-sentinel.el @@ -0,0 +1,72 @@ +;;; test-calendar-sync-source-fetch-sentinel.el --- Tests for the fetch sentinel -*- lexical-binding: t; -*- + +;;; Commentary: +;; calendar-sync--fetch-sentinel-finish is the extracted tail of the async +;; .ics fetch sentinel. The async-worker tests stub the whole fetch, so its +;; success, failure, and temp-file-cleanup branches were never exercised. +;; These tests drive the helper directly with fake success/failure inputs, +;; no live curl process. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'calendar-sync) + +(ert-deftest test-calendar-sync-fetch-sentinel-success-passes-temp-file () + "Normal: on success the callback gets the temp file and it is not deleted." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (buffer (generate-new-buffer " *cs-test*")) + (got 'unset)) + (unwind-protect + (progn + (calendar-sync--fetch-sentinel-finish + t "finished\n" temp-file buffer (lambda (r) (setq got r))) + (should (equal got temp-file)) + (should (file-exists-p temp-file)) + (should-not (buffer-live-p buffer))) + (when (file-exists-p temp-file) (delete-file temp-file)) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest test-calendar-sync-fetch-sentinel-failure-deletes-and-passes-nil () + "Error: on failure the temp file is deleted and the callback gets nil." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (buffer (generate-new-buffer " *cs-test*")) + (got 'unset) + (logged nil)) + (unwind-protect + (cl-letf (((symbol-function 'calendar-sync--log-silently) + (lambda (&rest _) (setq logged t)))) + (calendar-sync--fetch-sentinel-finish + nil "exited abnormally with code 22\n" temp-file buffer + (lambda (r) (setq got r))) + (should (null got)) + (should-not (file-exists-p temp-file)) + (should logged) + (should-not (buffer-live-p buffer))) + (when (file-exists-p temp-file) (delete-file temp-file)) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest test-calendar-sync-fetch-sentinel-failure-tolerates-missing-temp-file () + "Boundary: failure with the temp file already gone does not error." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (got 'unset)) + (delete-file temp-file) + (cl-letf (((symbol-function 'calendar-sync--log-silently) #'ignore)) + (calendar-sync--fetch-sentinel-finish + nil "failed\n" temp-file nil (lambda (r) (setq got r))) + (should (null got))))) + +(ert-deftest test-calendar-sync-fetch-sentinel-tolerates-dead-buffer () + "Boundary: a already-dead process buffer is not touched on success." + (let ((temp-file (make-temp-file "calendar-sync-sentinel-" nil ".ics")) + (got 'unset)) + (unwind-protect + (progn + (calendar-sync--fetch-sentinel-finish + t "finished\n" temp-file nil (lambda (r) (setq got r))) + (should (equal got temp-file))) + (when (file-exists-p temp-file) (delete-file temp-file))))) + +(provide 'test-calendar-sync-source-fetch-sentinel) +;;; test-calendar-sync-source-fetch-sentinel.el ends here diff --git a/tests/test-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-config-utilities--recompile-emacs-home.el b/tests/test-config-utilities--recompile-emacs-home.el index 18d17f96..da364e24 100644 --- a/tests/test-config-utilities--recompile-emacs-home.el +++ b/tests/test-config-utilities--recompile-emacs-home.el @@ -81,20 +81,29 @@ Returns the temp dir path." (should-not (file-exists-p (expand-file-name "sub/c.elc" dir)))) (delete-directory dir t)))) -(ert-deftest test-config-utilities-recompile-removes-eln-dir-on-native-path () - "Boundary: the native path removes the eln cache directory when present." +(ert-deftest test-config-utilities-recompile-removes-eln-cache-dir-on-native-path () + "Boundary: the native path removes the eln-cache directory when present. +The native cache is eln-cache/, not eln/, so that is the directory to clear." (let ((dir (test-config-utilities--make-recompile-fixture)) - (eln-dir nil)) + (eln-cache-dir nil)) (unwind-protect (progn - (setq eln-dir (expand-file-name "eln" dir)) - (make-directory eln-dir) - (with-temp-file (expand-file-name "stale.eln" eln-dir) (insert "")) + (setq eln-cache-dir (expand-file-name "eln-cache" dir)) + (make-directory eln-cache-dir) + (with-temp-file (expand-file-name "stale.eln" eln-cache-dir) (insert "")) (cl-letf (((symbol-function 'native-compile-async) (lambda (&rest _) nil))) (cj/--recompile-emacs-home dir t)) - (should-not (file-exists-p eln-dir))) + (should-not (file-exists-p eln-cache-dir))) (delete-directory dir t)))) +(ert-deftest test-config-utilities-native-comp-detection-not-boundp () + "Regression: native-comp detection must not test `boundp' of the async +function -- native-compile-async is a function, so `boundp' is always nil and +native compilation would never be selected. On a native-comp build, detection +returns non-nil." + (when (and (fboundp 'native-comp-available-p) (native-comp-available-p)) + (should (cj/--native-comp-p)))) + (ert-deftest test-config-utilities-recompile-removes-elc-dir-on-byte-path () "Boundary: the byte path removes the elc cache directory when present." (let ((dir (test-config-utilities--make-recompile-fixture)) diff --git a/tests/test-custom-buffer-file--view-email-in-buffer.el b/tests/test-custom-buffer-file--view-email-in-buffer.el index 99e0e44d..b0209b78 100644 --- a/tests/test-custom-buffer-file--view-email-in-buffer.el +++ b/tests/test-custom-buffer-file--view-email-in-buffer.el @@ -13,6 +13,7 @@ ;;; Code: (require 'ert) +(require 'cl-lib) (require 'testutil-general) (require 'custom-buffer-file) @@ -233,5 +234,24 @@ Note: shr may insert newlines between words for wrapping." (kill-buffer))) (test-email--teardown))) +(ert-deftest test-custom-buffer-file--view-email-no-displayable-destroys-handle () + "Error: the MIME handle is destroyed even when no displayable part is found. +The `user-error' fires before cleanup, so without `unwind-protect' the dissected +handle leaks." + (test-email--setup) + (unwind-protect + (let ((eml-file (test-email--create-eml-file test-email--image-only)) + (destroy-called nil)) + (with-current-buffer (find-file-noselect eml-file) + (let ((real (symbol-function 'mm-destroy-parts))) + (cl-letf (((symbol-function 'mm-destroy-parts) + (lambda (handle) + (setq destroy-called t) + (funcall real handle)))) + (should-error (cj/view-email-in-buffer) :type 'user-error))) + (should destroy-called) + (kill-buffer))) + (test-email--teardown))) + (provide 'test-custom-buffer-file--view-email-in-buffer) ;;; test-custom-buffer-file--view-email-in-buffer.el ends here diff --git a/tests/test-custom-buffer-file-copy-link-to-buffer-file.el b/tests/test-custom-buffer-file-copy-link-to-buffer-file.el index 262968d6..5ee57b3a 100644 --- a/tests/test-custom-buffer-file-copy-link-to-buffer-file.el +++ b/tests/test-custom-buffer-file-copy-link-to-buffer-file.el @@ -4,7 +4,8 @@ ;; Tests for the cj/copy-link-to-buffer-file function from custom-buffer-file.el ;; ;; This function copies the full file:// path of the current buffer's file to -;; the kill ring. For non-file buffers, it does nothing (no error). +;; the kill ring. For non-file buffers, it signals a user-error, matching its +;; sibling copy commands. ;;; Code: @@ -58,12 +59,12 @@ (test-copy-link-teardown))) (ert-deftest test-copy-link-non-file-buffer () - "Should do nothing for non-file buffer without error." + "Error: a non-file buffer signals `user-error' and leaves the kill ring alone." (test-copy-link-setup) (unwind-protect (with-temp-buffer (setq kill-ring nil) - (cj/copy-link-to-buffer-file) + (should-error (cj/copy-link-to-buffer-file) :type 'user-error) (should (null kill-ring))) (test-copy-link-teardown))) @@ -195,13 +196,13 @@ (test-copy-link-teardown))) (ert-deftest test-copy-link-scratch-buffer () - "Should do nothing for *scratch* buffer." + "Error: the *scratch* buffer (no file) signals `user-error'." (test-copy-link-setup) (unwind-protect (progn (setq kill-ring nil) (with-current-buffer "*scratch*" - (cj/copy-link-to-buffer-file) + (should-error (cj/copy-link-to-buffer-file) :type 'user-error) (should (null kill-ring)))) (test-copy-link-teardown))) diff --git a/tests/test-custom-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-case-title-case-region.el b/tests/test-custom-case-title-case-region.el index 383ae927..82b4966a 100644 --- a/tests/test-custom-case-title-case-region.el +++ b/tests/test-custom-case-title-case-region.el @@ -60,16 +60,17 @@ an active region, and return the result." "The Art of War"))) (ert-deftest test-custom-case-title-case-region-normal-all-minor-words () - "All minor words in the skip list should be lowercased in mid-sentence." + "All minor words in the skip list should be lowercased in mid-sentence. +\"is\" is a linking verb, so it is a major word and is capitalized." (should (equal (test-title-case--on-string "go a an and as at but by for if in is nor of on or so the to yet go") - "Go a an and as at but by for if in is nor of on or so the to yet Go"))) + "Go a an and as at but by for if in Is nor of on or so the to yet Go"))) (ert-deftest test-custom-case-title-case-region-normal-four-letter-words-capitalized () "Words of four or more letters should always be capitalized. -Note: 'is' is explicitly in the minor word list, so it stays lowercase." +\"is\" is a linking verb (a major word), so it is capitalized too." (should (equal (test-title-case--on-string "this is from that with over") - "This is From That With Over"))) + "This Is From That With Over"))) (ert-deftest test-custom-case-title-case-region-normal-allcaps-input () "All-caps input should be downcased first, then title-cased." @@ -94,7 +95,16 @@ Note: 'is' is explicitly in the minor word list, so it stays lowercase." (ert-deftest test-custom-case-title-case-region-normal-question-resets () "Word immediately after a question mark should be capitalized, even if minor." (should (equal (test-title-case--on-string "really? the answer is no") - "Really? The Answer is No"))) + "Really? The Answer Is No"))) + +(ert-deftest test-custom-case-title-case-region-normal-last-word-capitalized () + "The last word is always capitalized, even a minor one." + (should (equal (test-title-case--on-string "the art of") "The Art Of"))) + +(ert-deftest test-custom-case-title-case-region-normal-period-restarts () + "A word after a sentence-ending period should be capitalized." + (should (equal (test-title-case--on-string "one. the next sentence") + "One. The Next Sentence"))) (ert-deftest test-custom-case-title-case-region-normal-hyphenated-word () "Second part of a hyphenated word should NOT be capitalized." @@ -141,7 +151,7 @@ Note: 'is' is explicitly in the minor word list, so it stays lowercase." (ert-deftest test-custom-case-title-case-region-boundary-unicode-words () "Unicode characters should pass through without error." (should (equal (test-title-case--on-string "the café is nice") - "The Café is Nice"))) + "The Café Is Nice"))) (ert-deftest test-custom-case-title-case-region-boundary-numbers-in-text () "Numbers mixed with text should not break title casing." diff --git a/tests/test-custom-comments-comment-inline-border.el b/tests/test-custom-comments-comment-inline-border.el index 78e86035..305a2c7a 100644 --- a/tests/test-custom-comments-comment-inline-border.el +++ b/tests/test-custom-comments-comment-inline-border.el @@ -120,6 +120,16 @@ Returns the buffer string for assertions." (let ((result (test-inline-border-at-column 0 ";;" "" "=" "" 10))) (should (string-match-p ";" result)))) +(ert-deftest test-inline-border-elisp-fills-exact-width-all-parities () + "Boundary: even, odd, and empty text all fill LENGTH exactly. +Even-length and empty text used to come out two columns short because the +right decoration count keyed off text-length parity instead of the remaining +width, so stacked dividers of differing text lengths misaligned." + (dolist (text '("" "X" "EVEN" "ODD" "Header")) + (let* ((result (test-inline-border-at-column 0 ";;" "" "=" text 50)) + (line (string-trim-right result "\n"))) + (should (= 50 (length line)))))) + (ert-deftest test-inline-border-elisp-text-centering-even () "Should center text properly with even length." (let ((result (test-inline-border-at-column 0 ";;" "" "=" "EVEN" 70))) diff --git a/tests/test-custom-comments-comment-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-comment-reformat.el b/tests/test-custom-comments-comment-reformat.el index 83248aee..91b7dfe3 100644 --- a/tests/test-custom-comments-comment-reformat.el +++ b/tests/test-custom-comments-comment-reformat.el @@ -146,19 +146,12 @@ Insert CONTENT-BEFORE, select all, run cj/comment-reformat, verify EXPECTED-AFTE (should (string-match-p ";; Start line 1.*Start line 2" (buffer-string))))) (ert-deftest test-comment-reformat-elisp-no-region-active () - "Should show message when no region selected." + "Should signal `user-error' when no region is selected." (with-temp-buffer (emacs-lisp-mode) (insert ";; Comment line") (deactivate-mark) - (let ((message-log-max nil) - (messages '())) - ;; Capture messages - (cl-letf (((symbol-function 'message) - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) - (cj/comment-reformat) - (should (string-match-p "No region was selected" (car messages))))))) + (should-error (cj/comment-reformat) :type 'user-error))) (ert-deftest test-comment-reformat-elisp-read-only-buffer () "Should signal error in read-only buffer." diff --git a/tests/test-custom-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-custom-datetime-all-methods.el b/tests/test-custom-datetime-all-methods.el index 62b421bd..1f31c6c4 100644 --- a/tests/test-custom-datetime-all-methods.el +++ b/tests/test-custom-datetime-all-methods.el @@ -54,9 +54,10 @@ (should (string-match-p "14:30:45" result)))) (ert-deftest test-custom-datetime-all-methods-normal-sortable-time () - "cj/insert-sortable-time should insert time with AM/PM and timezone." + "cj/insert-sortable-time should insert 24-hour time so it sorts lexically." (let ((result (test-datetime--run #'cj/insert-sortable-time))) - (should (string-match-p "02:30:45 PM" result)))) + (should (string-match-p "14:30:45" result)) + (should-not (string-match-p "PM" result)))) (ert-deftest test-custom-datetime-all-methods-normal-readable-time () "cj/insert-readable-time should insert short time with AM/PM." diff --git a/tests/test-custom-line-paragraph-duplicate-line-or-region.el b/tests/test-custom-line-paragraph-duplicate-line-or-region.el index 84f5bc2d..9e501086 100644 --- a/tests/test-custom-line-paragraph-duplicate-line-or-region.el +++ b/tests/test-custom-line-paragraph-duplicate-line-or-region.el @@ -327,6 +327,40 @@ (should (> (length (buffer-string)) (length "line one\nline two\nline three")))) (test-duplicate-line-or-region-teardown))) +(ert-deftest test-duplicate-line-or-region-mid-line-bounds-duplicate-whole-lines () + "A region ending mid-line duplicates every whole line it touches, no splits. +The old open-line loop split the mid-line-ending line instead." + (test-duplicate-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (insert "aaa\nbbb\nccc") + (transient-mark-mode 1) + (goto-char (point-min)) + (forward-char 1) ; mid first line + (set-mark (point)) + (forward-line 1) + (forward-char 2) ; mid second line + (activate-mark) + (cj/duplicate-line-or-region) + (should (string= "aaa\nbbb\naaa\nbbb\nccc" (buffer-string)))) + (test-duplicate-line-or-region-teardown))) + +(ert-deftest test-duplicate-line-or-region-ends-at-bol-no-extra-empty-line () + "A region ending at beginning-of-line duplicates only the fully-included lines. +The old open-line loop duplicated a stray empty line here." + (test-duplicate-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (insert "aaa\nbbb\nccc") + (transient-mark-mode 1) + (goto-char (point-min)) + (set-mark (point)) + (forward-line 2) ; region "aaa\nbbb\n", ends at bol of ccc + (activate-mark) + (cj/duplicate-line-or-region) + (should (string= "aaa\nbbb\naaa\nbbb\nccc" (buffer-string)))) + (test-duplicate-line-or-region-teardown))) + (ert-deftest test-duplicate-line-or-region-trailing-whitespace () "Should preserve trailing whitespace." (test-duplicate-line-or-region-setup) diff --git a/tests/test-custom-line-paragraph-join-line-or-region.el b/tests/test-custom-line-paragraph-join-line-or-region.el index f8738910..5d421683 100644 --- a/tests/test-custom-line-paragraph-join-line-or-region.el +++ b/tests/test-custom-line-paragraph-join-line-or-region.el @@ -62,8 +62,8 @@ (should (string-match-p "line one line two" (buffer-string)))) (test-join-line-or-region-teardown))) -(ert-deftest test-join-line-or-region-no-region-adds-newline-after-join () - "Without region, should add newline after joining." +(ert-deftest test-join-line-or-region-no-region-adds-newline-at-end-of-buffer () + "Without region, joining the last line adds a trailing newline at end of buffer." (test-join-line-or-region-setup) (unwind-protect (with-temp-buffer @@ -73,6 +73,20 @@ (should (string-suffix-p "\n" (buffer-string)))) (test-join-line-or-region-teardown))) +(ert-deftest test-join-line-or-region-no-region-mid-buffer-no-blank-line () + "Without region, joining a non-last line must not insert a blank line. +The trailing newline belongs only at end of buffer; adding it unconditionally +left a stray blank line between the joined line and the rest of the buffer." + (test-join-line-or-region-setup) + (unwind-protect + (with-temp-buffer + (insert "line one\nline two\nline three") + (goto-char (point-min)) + (forward-line 1) ; point on "line two", not the last line + (cj/join-line-or-region) + (should (string= "line one line two\nline three" (buffer-string)))) + (test-join-line-or-region-teardown))) + (ert-deftest test-join-line-or-region-with-region-joins-all-lines () "With region, should join all lines in region." (test-join-line-or-region-setup) diff --git a/tests/test-custom-line-paragraph-jump-to-matching-paren.el b/tests/test-custom-line-paragraph-jump-to-matching-paren.el index 31853da6..bd24faed 100644 --- a/tests/test-custom-line-paragraph-jump-to-matching-paren.el +++ b/tests/test-custom-line-paragraph-jump-to-matching-paren.el @@ -83,11 +83,11 @@ POINT-POSITION is 1-indexed (1 = first character)." ;;; Normal Cases - Backward Jump (Closing to Opening) (ert-deftest test-jump-paren-backward-simple () - "Should jump backward from closing paren to opening paren." + "Should jump from a closing paren to its matching opening paren." ;; Text: "(hello)" ;; Start at position 7 (on closing paren) - ;; Should end at position 2 (after opening paren) - (should (= 2 (test-jump-to-matching-paren "(hello)" 7)))) + ;; Should end at position 1 (the matching opening paren) + (should (= 1 (test-jump-to-matching-paren "(hello)" 7)))) (ert-deftest test-jump-paren-backward-nested () "Should jump backward over nested parens from after outer closing." @@ -97,11 +97,11 @@ POINT-POSITION is 1-indexed (1 = first character)." (should (= 1 (test-jump-to-matching-paren "(foo (bar))" 12)))) (ert-deftest test-jump-paren-backward-inner-nested () - "Should jump backward from inner closing paren." + "Should jump from an inner closing paren to its matching inner opener." ;; Text: "(foo (bar))" ;; Start at position 10 (on inner closing paren) - ;; Should end at position 7 (after inner opening paren) - (should (= 7 (test-jump-to-matching-paren "(foo (bar))" 10)))) + ;; Should end at position 6 (the matching inner opening paren) + (should (= 6 (test-jump-to-matching-paren "(foo (bar))" 10)))) (ert-deftest test-jump-bracket-backward () "Should jump backward from after closing bracket." @@ -145,11 +145,11 @@ POINT-POSITION is 1-indexed (1 = first character)." (should (= 1 (test-jump-to-matching-paren "(hello" 1)))) (ert-deftest test-jump-paren-unmatched-closing () - "Should move to beginning from unmatched closing paren." + "Should stay put on an unmatched closing paren (no matching opener)." ;; Text: "hello)" ;; Start at position 6 (on closing paren with no opening) - ;; backward-sexp with unmatched closing paren goes to beginning - (should (= 1 (test-jump-to-matching-paren "hello)" 6)))) + ;; There is no matching opener, so point is restored and stays at 6 + (should (= 6 (test-jump-to-matching-paren "hello)" 6)))) ;;; Boundary Cases - Empty Delimiters @@ -161,11 +161,11 @@ POINT-POSITION is 1-indexed (1 = first character)." (should (= 3 (test-jump-to-matching-paren "()" 1)))) (ert-deftest test-jump-paren-empty-backward () - "Should stay put when on closing paren of empty parens." + "Should jump from the closing paren of empty parens to its opener." ;; Text: "()" ;; Start at position 2 (on closing paren) - ;; backward-sexp from closing of empty parens gives an error, so stays at 2 - (should (= 2 (test-jump-to-matching-paren "()" 2)))) + ;; Should end at position 1 (the matching opening paren) + (should (= 1 (test-jump-to-matching-paren "()" 2)))) ;;; Boundary Cases - Multiple Delimiter Types diff --git a/tests/test-custom-ordering-number-lines.el b/tests/test-custom-ordering-number-lines.el index adda84f0..142e5561 100644 --- a/tests/test-custom-ordering-number-lines.el +++ b/tests/test-custom-ordering-number-lines.el @@ -122,9 +122,10 @@ Returns the transformed string." (should (string= result "1. ")))) (ert-deftest test-number-lines-empty-lines () - "Should number empty lines." + "Should number empty lines, treating the final newline as a terminator. +The old split counted the trailing newline as a spurious third line." (let ((result (test-number-lines "\n\n" "N. " nil))) - (should (string= result "1. \n2. \n3. ")))) + (should (string= result "1. \n2. \n")))) (ert-deftest test-number-lines-with-existing-numbers () "Should number lines that already have content." diff --git a/tests/test-custom-ordering-reverse-lines.el b/tests/test-custom-ordering-reverse-lines.el index 3c71362d..5b8c01ac 100644 --- a/tests/test-custom-ordering-reverse-lines.el +++ b/tests/test-custom-ordering-reverse-lines.el @@ -86,9 +86,11 @@ Returns the transformed string." (should (string= result "b\n\na")))) (ert-deftest test-reverse-lines-trailing-newline () - "Should handle trailing newline." + "Should reverse the lines and preserve the trailing newline. +The old split dropped the trailing newline into a leading empty line, +producing \"\\nline2\\nline1\"." (let ((result (test-reverse-lines "line1\nline2\n"))) - (should (string= result "\nline2\nline1")))) + (should (string= result "line2\nline1\n")))) (ert-deftest test-reverse-lines-only-newlines () "Should reverse lines that are only newlines." diff --git a/tests/test-custom-text-enclose-indent.el b/tests/test-custom-text-enclose-indent.el index e9042d35..f37d1800 100644 --- a/tests/test-custom-text-enclose-indent.el +++ b/tests/test-custom-text-enclose-indent.el @@ -43,6 +43,35 @@ Returns the transformed string." Returns the transformed string." (cj/--dedent-lines text count)) +;;; Interactive default resolution (the prefix-arg decoupling fix) + +(ert-deftest test-indent-lines-interactive-no-prefix-is-four-spaces () + "Interactive: no prefix indents by 4, spaces when `indent-tabs-mode' is nil. +The old \"p\\nP\" spec defaulted count to 1 and forced tabs on any prefix." + (with-temp-buffer + (setq-local indent-tabs-mode nil) + (insert "line") + (let ((current-prefix-arg nil)) + (call-interactively #'cj/indent-lines-in-region-or-buffer)) + (should (string= " line" (buffer-string))))) + +(ert-deftest test-indent-lines-interactive-follows-indent-tabs-mode () + "Interactive: tabs-vs-spaces follows `indent-tabs-mode', not the prefix arg." + (with-temp-buffer + (setq-local indent-tabs-mode t) + (insert "line") + (let ((current-prefix-arg nil)) + (call-interactively #'cj/indent-lines-in-region-or-buffer)) + (should (string= "\t\t\t\tline" (buffer-string))))) + +(ert-deftest test-dedent-lines-interactive-no-prefix-is-four () + "Interactive: no prefix removes up to 4 leading whitespace characters." + (with-temp-buffer + (insert " line") ; eight leading spaces + (let ((current-prefix-arg nil)) + (call-interactively #'cj/dedent-lines-in-region-or-buffer)) + (should (string= " line" (buffer-string))))) + ;;; Indent Tests - Normal Cases with Spaces (ert-deftest test-indent-single-line-4-spaces () diff --git a/tests/test-dashboard-config-launchers.el b/tests/test-dashboard-config-launchers.el index 53c46caa..76fbcc42 100644 --- a/tests/test-dashboard-config-launchers.el +++ b/tests/test-dashboard-config-launchers.el @@ -28,20 +28,21 @@ ;; Telegram moved from "g" to "G" so "g" is free for dashboard refresh. ;; Signal ("S") added as the 14th launcher. ;; Weather ("w") added after Agenda as the 15th launcher (top-row daily glance). -(defconst test-dash--keys '("c" "d" "t" "a" "w" "r" "b" "f" "m" "e" "i" "G" "s" "l" "S")) +(defconst test-dash--keys '("c" "d" "t" "a" "w" "r" "b" "f" "m" "e" "i" "G" "s" "l")) ;; ----------------------------- launcher table -------------------------------- (ert-deftest test-dashboard-launchers-keys-in-order () - "Normal: 15 launchers with the expected keys in display order." - (should (= 15 (length cj/dashboard--launchers))) + "Normal: 14 launchers with the expected keys in display order. +(Signal left the table when the signel client was retired to archive/.)" + (should (= 14 (length cj/dashboard--launchers))) (should (equal test-dash--keys (mapcar (lambda (l) (nth 0 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-launchers-labels-in-order () "Normal: labels in display order (Telegram and Slack reordered so Slack sits next to Linear on the last navigator row)." (should (equal '("Code" "Files" "Terminal" "Agenda" "Weather" "Feeds" "Books" - "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear" "Signal") + "Flashcards" "Music" "Email" "IRC" "Telegram" "Slack" "Linear") (mapcar (lambda (l) (nth 3 l)) cj/dashboard--launchers)))) (ert-deftest test-dashboard-row-sizes-cover-all-launchers () @@ -51,9 +52,9 @@ next to Linear on the last navigator row)." ;; --------------------------- navigator rows ---------------------------------- -(ert-deftest test-dashboard-navigator-rows-grouped-5-4-3-3 () - "Normal: navigator derives rows per `cj/dashboard--row-sizes' (5 4 3 3), with -Weather joining the top row and Slack, Linear, and Signal sharing the last row." +(ert-deftest test-dashboard-navigator-rows-grouped-5-4-3-2 () + "Normal: navigator derives rows per `cj/dashboard--row-sizes' (5 4 3 2), with +Weather joining the top row and Slack and Linear pairing on the last row." (cl-letf (((symbol-function 'nerd-icons-faicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-devicon) (lambda (n &rest _) (concat "I:" n))) ((symbol-function 'nerd-icons-mdicon) (lambda (n &rest _) (concat "I:" n))) @@ -62,10 +63,10 @@ Weather joining the top row and Slack, Linear, and Signal sharing the last row." ((symbol-function 'nerd-icons-wicon) (lambda (n &rest _) (concat "I:" n)))) (let ((rows (cj/dashboard--navigator-rows))) (should (= 4 (length rows))) - (should (equal '(5 4 3 3) (mapcar #'length rows))) + (should (equal '(5 4 3 2) (mapcar #'length rows))) (should (equal '("Code" "Files" "Terminal" "Agenda" "Weather") (mapcar (lambda (b) (nth 1 b)) (nth 0 rows)))) - (should (equal '("Slack" "Linear" "Signal") + (should (equal '("Slack" "Linear") (mapcar (lambda (b) (nth 1 b)) (nth 3 rows)))) (let ((btn (car (car rows)))) ; (icon label tooltip action nil " " "") (should (string= "I:nf-fa-code" (nth 0 btn))) @@ -100,7 +101,6 @@ Weather joining the top row and Slack, Linear, and Signal sharing the last row." ((symbol-function 'cj/slack-start) (lambda (&rest _) (push 'slack calls))) ((symbol-function 'cj/telega) (lambda (&rest _) (push 'tg calls))) ((symbol-function 'pearl-list-issues) (lambda (&rest _) (push 'linear calls))) - ((symbol-function 'cj/signel-message) (lambda (&rest _) (push 'signal calls))) ;; wttrin is invoked via `call-interactively', so the stub must be ;; a command -- a plain variadic lambda masked the real arity bug. ((symbol-function 'wttrin) (lambda (&rest _) (interactive) (push 'weather calls)))) @@ -112,9 +112,8 @@ Weather joining the top row and Slack, Linear, and Signal sharing the last row." (should (memq 'linear calls)) (should (memq 'm-toggle calls)) (should (memq 'm-load calls)) - (should (memq 'signal calls)) (should (memq 'weather calls)) - (should (= 16 (length calls)))))) ; 15 keys, Music fires two + (should (= 15 (length calls)))))) ; 14 keys, Music fires two (provide 'test-dashboard-config-launchers) ;;; test-dashboard-config-launchers.el ends here diff --git a/tests/test-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-eat-config--xtwinops.el b/tests/test-eat-config--xtwinops.el new file mode 100644 index 00000000..29f87f2f --- /dev/null +++ b/tests/test-eat-config--xtwinops.el @@ -0,0 +1,120 @@ +;;; test-eat-config--xtwinops.el --- Tests for the EAT XTWINOPS window-size reply -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for the XTWINOPS (CSI <n> t) window-size responder. eat 0.9.4 +;; has no CSI <n> t handler, so it silently drops the window-size requests +;; tmux 3.7b sends to learn the cell pixel size it needs before it will emit +;; Sixel -- images then never render inside EAT. The module answers three +;; requests: 14 (text area in pixels), 16 (cell size in pixels), 18 (text area +;; in characters). +;; +;; Two pure pieces carry the logic and are tested here directly: +;; - `cj/--eat-xtwinops-report' computes the reply string from the display and +;; cell dimensions. +;; - `cj/--eat-xtwinops-queries' extracts the request numbers from a chunk of +;; terminal output. +;; The thin accessor glue (`cj/--eat-send-window-size-report', which reads the +;; live `eat--t-term' struct) is verified in the running daemon, since eat's +;; structs are not loadable under `make test' (no package-initialize). The +;; detector's dispatch is tested against a recording stub of the responder. + +;;; Code: + +(require 'ert) + +;; Stub keymap dep before loading the module (matches the other module tests). +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'eat-config) + +;;; --------------------------- reply computation ---------------------------- + +(ert-deftest test-eat-config-xtwinops-report-normal-14-text-area-pixels () + "Normal: request 14 reports text-area size in pixels (rows*ch by cols*cw)." + ;; 80x24 chars, 10x20 px cells -> height 24*20=480, width 80*10=800. + (should (equal (cj/--eat-xtwinops-report 14 80 24 10 20) + "\e[4;480;800t"))) + +(ert-deftest test-eat-config-xtwinops-report-normal-16-cell-pixels () + "Normal: request 16 reports the cell size in pixels (height then width)." + (should (equal (cj/--eat-xtwinops-report 16 80 24 10 20) + "\e[6;20;10t"))) + +(ert-deftest test-eat-config-xtwinops-report-normal-18-text-area-chars () + "Normal: request 18 reports the text-area size in characters (rows then cols)." + (should (equal (cj/--eat-xtwinops-report 18 80 24 10 20) + "\e[8;24;80t"))) + +(ert-deftest test-eat-config-xtwinops-report-boundary-unit-cells () + "Boundary: with eat's default 1x1 px cells, pixel dims equal the char dims." + (should (equal (cj/--eat-xtwinops-report 14 80 24 1 1) "\e[4;24;80t")) + (should (equal (cj/--eat-xtwinops-report 16 80 24 1 1) "\e[6;1;1t"))) + +(ert-deftest test-eat-config-xtwinops-report-error-unknown-request-is-nil () + "Error: any request number other than 14/16/18 returns nil (unanswered)." + (should (null (cj/--eat-xtwinops-report 15 80 24 10 20))) + (should (null (cj/--eat-xtwinops-report 24 80 24 10 20))) + (should (null (cj/--eat-xtwinops-report nil 80 24 10 20)))) + +;;; ----------------------------- query detection ---------------------------- + +(ert-deftest test-eat-config-xtwinops-queries-normal-single () + "Normal: a lone CSI 14 t query is detected." + (should (equal (cj/--eat-xtwinops-queries "\e[14t") '(14)))) + +(ert-deftest test-eat-config-xtwinops-queries-normal-embedded-multiple () + "Normal: several queries embedded in other output are returned in order." + (should (equal (cj/--eat-xtwinops-queries "foo\e[14tbar\e[18tbaz\e[16t") + '(14 18 16)))) + +(ert-deftest test-eat-config-xtwinops-queries-boundary-none () + "Boundary: output with no XTWINOPS query returns nil, including empty." + (should (null (cj/--eat-xtwinops-queries ""))) + (should (null (cj/--eat-xtwinops-queries "hello\e[0m\e[2J")))) + +(ert-deftest test-eat-config-xtwinops-queries-error-unhandled-ops-ignored () + "Error: CSI t ops we do not answer (and parametrized forms) are not matched. +`\\e[24t' is a resize op, `\\e[3;14t' carries a leading param -- neither is the +bare CSI 14/16/18 t we answer, so both are ignored." + (should (null (cj/--eat-xtwinops-queries "\e[24t"))) + (should (null (cj/--eat-xtwinops-queries "\e[3;14t"))) + (should (null (cj/--eat-xtwinops-queries "\e[114t")))) + +;;; --------------------------- advice-needed guard -------------------------- + +(ert-deftest test-eat-config-xtwinops-advice-needed-normal-eat-0-9-4 () + "Normal: on eat 0.9.4 (no upstream CSI t clause) the advice is needed." + ;; The upstream parser clause defines `eat--t-send-window-size-report'; + ;; 0.9.4 does not, so it must be unbound here. + (should-not (fboundp 'eat--t-send-window-size-report)) + (should (cj/--eat-xtwinops-advice-needed-p))) + +(ert-deftest test-eat-config-xtwinops-advice-needed-boundary-upstream-ships () + "Boundary: once upstream defines the parser clause, the advice must NOT +install -- both would answer and tmux gets a double reply." + (cl-letf (((symbol-function 'eat--t-send-window-size-report) #'ignore)) + (should-not (cj/--eat-xtwinops-advice-needed-p)))) + +;;; ------------------------- detector dispatch (seam) ----------------------- + +(ert-deftest test-eat-config-xtwinops-answer-dispatches-once-per-query () + "Integration: the detector calls the responder once per query, in order. +Mocks only our own responder seam (`cj/--eat-send-window-size-report'); the +detector under test does the real query extraction." + (let ((calls '())) + (cl-letf (((symbol-function 'cj/--eat-send-window-size-report) + (lambda (n) (push n calls)))) + (cj/--eat-answer-xtwinops "\e[14t\e[16t\e[18t")) + (should (equal (nreverse calls) '(14 16 18))))) + +(ert-deftest test-eat-config-xtwinops-answer-no-query-no-call () + "Boundary: output with no query never calls the responder." + (let ((called nil)) + (cl-letf (((symbol-function 'cj/--eat-send-window-size-report) + (lambda (_n) (setq called t)))) + (cj/--eat-answer-xtwinops "no query here\e[2J")) + (should-not called))) + +(provide 'test-eat-config--xtwinops) +;;; test-eat-config--xtwinops.el ends here diff --git a/tests/test-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-flycheck-config-ledger-hook.el b/tests/test-flycheck-config-ledger-hook.el new file mode 100644 index 00000000..e9444b71 --- /dev/null +++ b/tests/test-flycheck-config-ledger-hook.el @@ -0,0 +1,31 @@ +;;; test-flycheck-config-ledger-hook.el --- flycheck reaches ledger buffers -*- lexical-binding: t; -*- + +;;; Commentary: +;; `flycheck-ledger' registers a `ledger' checker, but a checker only runs where +;; `flycheck-mode' is on. Until 2026-07-10 flycheck-config enabled the mode in +;; `sh-mode' and `emacs-lisp-mode' only, and no `global-flycheck-mode' existed, so +;; an unbalanced transaction in a ledger file produced no warning at all. +;; +;; These tests pin the hook, not the checker. Whether the `ledger' checker itself +;; works is flycheck-ledger's problem; whether it ever gets a chance to run is ours. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'flycheck-config) + +(ert-deftest test-flycheck-config-enables-flycheck-in-ledger-buffers () + "Normal: opening a ledger buffer turns `flycheck-mode' on. +Without this, `flycheck-ledger' is loaded, its checker is registered, and +nothing ever lints a financial file." + (should (memq #'flycheck-mode (default-value 'ledger-mode-hook)))) + +(ert-deftest test-flycheck-config-keeps-its-existing-mode-hooks () + "Boundary: adding ledger doesn't displace the modes flycheck already covered." + (should (memq #'flycheck-mode (default-value 'sh-mode-hook))) + (should (memq #'flycheck-mode (default-value 'emacs-lisp-mode-hook)))) + +(provide 'test-flycheck-config-ledger-hook) +;;; test-flycheck-config-ledger-hook.el ends here diff --git a/tests/test-flyspell-and-abbrev.el b/tests/test-flyspell-and-abbrev.el index ef8cc637..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 () @@ -97,5 +115,27 @@ (cj/flyspell-on-for-buffer-type))) (should mode-called))) +;; --------------------------- cj/flyspell-then-abbrev ------------------------- + +(ert-deftest test-flyspell-then-abbrev-enables-mode-not-bare-rescan () + "Regression: cj/flyspell-then-abbrev routes the initial scan through +cj/flyspell-on-for-buffer-type, which enables flyspell-mode so it sticks. +The bare flyspell-buffer it replaced never turned the mode on, so the guard +never tripped and every C-' press re-scanned the whole buffer (O(buffer) per +keypress in large files)." + (let (on-called scan-called) + (cl-letf (((symbol-function 'cj/--require-spell-checker) #'ignore) + ((symbol-function 'cj/flyspell-on-for-buffer-type) + (lambda () (setq on-called t))) + ((symbol-function 'flyspell-buffer) + (lambda (&rest _) (setq scan-called t))) + ((symbol-function 'cj/flyspell-goto-previous-misspelling) + (lambda (&rest _) nil))) + (with-temp-buffer + (text-mode) + (cj/flyspell-then-abbrev nil))) + (should on-called) + (should-not scan-called))) + (provide 'test-flyspell-and-abbrev) ;;; test-flyspell-and-abbrev.el ends here diff --git a/tests/test-font-config--frame-lifecycle.el b/tests/test-font-config--frame-lifecycle.el deleted file mode 100644 index 8f338b99..00000000 --- a/tests/test-font-config--frame-lifecycle.el +++ /dev/null @@ -1,75 +0,0 @@ -;;; test-font-config--frame-lifecycle.el --- Tests for the lifted font frame helpers -*- lexical-binding: t; -*- - -;;; Commentary: -;; cj/apply-font-settings-to-frame, cj/cleanup-frame-list, and -;; cj/maybe-install-nerd-icons-fonts were defined inside use-package -;; :config / with-eval-after-load (unreachable under `make test'). Lifting -;; them to top level makes their branching unit-testable; env-gui-p and the -;; package side-effect calls are mocked at the boundary. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'font-config) - -(defvar cj/fontaine-configured-frames) - -(ert-deftest test-font-cleanup-frame-list-removes-frame () - "Normal: cleanup drops the given frame from the configured list." - (let ((cj/fontaine-configured-frames '(fr1 fr2 fr3))) - (cj/cleanup-frame-list 'fr2) - (should (equal cj/fontaine-configured-frames '(fr1 fr3))))) - -(ert-deftest test-font-apply-gui-unconfigured-sets-preset () - "Normal: a GUI frame not yet configured gets the preset and is tracked." - (let ((cj/fontaine-configured-frames nil) - (called nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) - (cj/apply-font-settings-to-frame (selected-frame))) - (should called) - (should (member (selected-frame) cj/fontaine-configured-frames)))) - -(ert-deftest test-font-apply-already-configured-is-noop () - "Boundary: an already-configured frame is not re-preset." - (let ((cj/fontaine-configured-frames (list (selected-frame))) - (called nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) - (cj/apply-font-settings-to-frame (selected-frame))) - (should-not called))) - -(ert-deftest test-font-apply-non-gui-is-noop () - "Boundary: without a GUI nothing is applied or tracked." - (let ((cj/fontaine-configured-frames nil) - (called nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () nil)) - ((symbol-function 'fontaine-set-preset) (lambda (_p) (setq called t)))) - (cj/apply-font-settings-to-frame (selected-frame))) - (should-not called) - (should-not (member (selected-frame) cj/fontaine-configured-frames)))) - -(ert-deftest test-font-maybe-install-icons-gui-missing-installs () - "Normal: GUI present and font missing triggers the install." - (let ((installed nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'cj/font-installed-p) (lambda (_n) nil)) - ((symbol-function 'nerd-icons-install-fonts) (lambda (&rest _) (setq installed t))) - ((symbol-function 'remove-hook) #'ignore)) - (cj/maybe-install-nerd-icons-fonts)) - (should installed))) - -(ert-deftest test-font-maybe-install-icons-already-present-skips () - "Boundary: an installed font means no install attempt." - (let ((installed nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) - ((symbol-function 'cj/font-installed-p) (lambda (_n) t)) - ((symbol-function 'nerd-icons-install-fonts) (lambda (&rest _) (setq installed t)))) - (cj/maybe-install-nerd-icons-fonts)) - (should-not installed))) - -(provide 'test-font-config--frame-lifecycle) -;;; test-font-config--frame-lifecycle.el ends here diff --git a/tests/test-font-config.el b/tests/test-font-config.el index 393a7758..06ea226b 100644 --- a/tests/test-font-config.el +++ b/tests/test-font-config.el @@ -4,11 +4,10 @@ ;; font-config.el is mostly top-level font/package setup. These smoke tests ;; cover the logic that should stay correct regardless of which fonts are -;; installed: the install check, and the daemon-frame font applier (env-gui-p -;; guard plus idempotency). The module :demand's fontaine and references -;; nerd-icons, so the tests skip when those packages are absent rather than -;; failing on a bare checkout. GUI and font lookups are stubbed so the run -;; stays headless. +;; installed: the install check, task-oriented Fontaine picker, persistence, +;; and emoji setup. The module :demand's fontaine and references nerd-icons, so +;; the tests skip when those packages are absent rather than failing on a bare +;; checkout. GUI and font lookups are stubbed so the run stays headless. ;;; Code: @@ -41,34 +40,32 @@ (cl-letf (((symbol-function 'find-font) (lambda (&rest _) nil))) (should (null (cj/font-installed-p "No Such Font 12345"))))) -;;; cj/apply-font-settings-to-frame +;;; cj/maybe-install-nerd-icons-fonts -(ert-deftest test-font-config-apply-font-settings-noop-without-gui () - "Boundary: on a non-GUI frame the applier does nothing and does not error." +(ert-deftest test-font-config-nerd-icons-missing-font-installs-on-gui () + "Normal: a missing Nerd Icons font is installed on a GUI frame." (skip-unless test-font-config--available) (require 'font-config) - (let ((cj/fontaine-configured-frames nil) - (applied nil)) - (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) nil)) - ((symbol-function 'fontaine-set-preset) - (lambda (&rest _) (setq applied t)))) - (cj/apply-font-settings-to-frame (selected-frame)) - (should-not applied) - (should-not cj/fontaine-configured-frames)))) - -(ert-deftest test-font-config-apply-font-settings-applies-once-per-frame () - "Normal: on a GUI frame the applier sets the preset once and is idempotent." - (skip-unless test-font-config--available) - (require 'font-config) - (let ((cj/fontaine-configured-frames nil) - (calls 0)) - (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) t)) - ((symbol-function 'fontaine-set-preset) - (lambda (&rest _) (setq calls (1+ calls))))) - (cj/apply-font-settings-to-frame (selected-frame)) - (cj/apply-font-settings-to-frame (selected-frame)) - (should (= calls 1)) - (should (memq (selected-frame) cj/fontaine-configured-frames))))) + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_name) nil)) + ((symbol-function 'nerd-icons-install-fonts) + (lambda (&rest _) (setq installed t))) + ((symbol-function 'remove-hook) #'ignore)) + (cj/maybe-install-nerd-icons-fonts)) + (should installed))) + +(ert-deftest test-font-config-nerd-icons-installed-font-skips-install () + "Boundary: an installed Nerd Icons font needs no install attempt." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((installed nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda () t)) + ((symbol-function 'cj/font-installed-p) (lambda (_name) t)) + ((symbol-function 'nerd-icons-install-fonts) + (lambda (&rest _) (setq installed t)))) + (cj/maybe-install-nerd-icons-fonts)) + (should-not installed))) ;;; cj/setup-emoji-fontset @@ -93,5 +90,248 @@ ((symbol-function 'set-fontset-font) (lambda (&rest _) t))) (should (progn (cj/setup-emoji-fontset) t)))) +;;; cj/set-emojify-display-style + +(defvar emojify-display-style) + +(ert-deftest test-font-config-emojify-display-style-image-on-gui () + "Normal: on a GUI frame the emoji display style is `image'." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((emojify-display-style nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) t))) + (cj/set-emojify-display-style) + (should (eq emojify-display-style 'image))))) + +(ert-deftest test-font-config-emojify-display-style-unicode-without-gui () + "Boundary: without a GUI the emoji display style is `unicode'." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((emojify-display-style nil)) + (cl-letf (((symbol-function 'env-gui-p) (lambda (&rest _) nil))) + (cj/set-emojify-display-style) + (should (eq emojify-display-style 'unicode))))) + +;;; cj/display-available-fonts + +(ert-deftest test-font-config-display-available-fonts-second-call-no-error () + "Error: a second invocation does not signal on the read-only buffer." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'font-family-list) + (lambda (&rest _) '("Fixture Font A" "Fixture Font B")))) + (unwind-protect + (progn + (cj/display-available-fonts) + ;; The first call ends in `special-mode' (read-only); the second must + ;; not signal when it erases and rewrites the buffer. + (cj/display-available-fonts) + (with-current-buffer "*Available Fonts*" + (should (> (buffer-size) 0)) + (should buffer-read-only))) + (when (get-buffer "*Available Fonts*") + (kill-buffer "*Available Fonts*"))))) + +;;; Fontaine workflow profiles + +(ert-deftest test-font-config-fontaine-presets-are-task-oriented () + "Normal: the picker exposes eight complete workflow destinations." + (skip-unless test-font-config--available) + (require 'font-config) + (should (equal (delq t (mapcar #'car fontaine-presets)) + '(everyday writing reading coding-xs coding-m coding-l coding-xl + presentation)))) + +(ert-deftest test-font-config-fontaine-candidates-describe-end-state () + "Normal: every profile label names its purpose, fonts, and point size." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((candidates (cj/fontaine-profile-candidates))) + (should (= (length candidates) 8)) + (should (member (nth 0 candidates) + '("Everyday — Berkeley Mono + Lexend · 13 pt" + "Everyday — Berkeley Mono + Lexend · 14 pt"))) + (should (equal (nth 1 candidates) + "Writing — Berkeley Mono + Merriweather · 14 pt")) + (should (equal (nth 2 candidates) + "Reading — Merriweather · 14 pt")) + (should (equal (nth 3 candidates) + "Coding XS — Berkeley Mono · 11 pt")) + (should (equal (nth 4 candidates) + "Coding M — Berkeley Mono · 13 pt")) + (should (equal (nth 5 candidates) + "Coding L — Berkeley Mono · 14 pt")) + (should (equal (nth 6 candidates) + "Coding XL — Berkeley Mono · 16 pt")) + (should (equal (nth 7 candidates) + "Presentation — Berkeley Mono + Lexend · 20 pt")))) + +(ert-deftest test-font-config-fontaine-candidate-round-trips-to-profile () + "Boundary: a displayed destination maps back to its Fontaine symbol." + (skip-unless test-font-config--available) + (require 'font-config) + (dolist (profile '(everyday writing reading coding-xs coding-m coding-l coding-xl + presentation)) + (let ((label (cj/fontaine-profile-label profile))) + (should (eq (cj/fontaine-profile-from-label label) profile))))) + +(ert-deftest test-font-config-fontaine-uses-one-monospace-family () + "Normal: every workflow profile uses Berkeley Mono for fixed pitch." + (skip-unless test-font-config--available) + (require 'font-config) + (dolist (profile '(everyday writing coding-xs coding-m coding-l coding-xl presentation)) + (let ((properties (fontaine--get-preset-properties profile))) + (should (equal (plist-get properties :default-family) + "BerkeleyMono Nerd Font"))))) + +(ert-deftest test-font-config-fontaine-reading-is-merriweather-only () + "Normal: Reading uses Merriweather for every primary face family." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((properties (fontaine--get-preset-properties 'reading))) + (dolist (property '(:default-family + :fixed-pitch-family + :fixed-pitch-serif-family + :variable-pitch-family)) + (should (equal (plist-get properties property) "Merriweather"))))) + +(ert-deftest test-font-config-fontaine-reading-properties-are-public () + "Normal: consumers can resolve Reading without Fontaine private functions." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((properties (cj/fontaine-profile-properties 'reading))) + (should (equal (plist-get properties :default-family) "Merriweather")) + (should (= (plist-get properties :default-height) 140)))) + +(ert-deftest test-font-config-fontaine-remaps-reading-buffer-locally () + "Normal: the local adapter applies all Reading families at an override height." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((calls nil)) + (cl-letf (((symbol-function 'face-remap-add-relative) + (lambda (face &rest properties) + (push (cons face properties) calls) + face))) + (should (equal (cj/fontaine-remap-buffer-to-profile 'reading 180) + '(default fixed-pitch fixed-pitch-serif variable-pitch)))) + (dolist (face '(default fixed-pitch fixed-pitch-serif variable-pitch)) + (should (member (list face :family "Merriweather" :height 180) + calls))))) + +(ert-deftest test-font-config-fontaine-ui-buffer-remaps-default-to-berkeley () + "Normal: minibuffer and echo buffers remap their default face to Berkeley." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((base nil)) + (cl-letf (((symbol-function 'face-remap-set-base) + (lambda (face &rest specs) (setq base (cons face specs))))) + (cj/fontaine-remap-ui-buffer)) + (should (equal base + '(default (:family "BerkeleyMono Nerd Font")))))) + +(ert-deftest test-font-config-fontaine-ui-chrome-stays-berkeley () + "Normal: Fontaine reasserts Berkeley on chrome faces and echo buffers." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((faces nil) + (remap-count 0)) + (cl-letf (((symbol-function 'facep) (lambda (_face) t)) + ((symbol-function 'set-face-attribute) + (lambda (face _frame &rest properties) + (push (cons face properties) faces))) + ((symbol-function 'get-buffer) (lambda (_name) (current-buffer))) + ((symbol-function 'cj/fontaine-remap-ui-buffer) + (lambda () (setq remap-count (1+ remap-count))))) + (cj/fontaine-keep-ui-chrome-monospace)) + (dolist (face '(mode-line mode-line-active mode-line-inactive + minibuffer-prompt)) + (should (member (list face :family "BerkeleyMono Nerd Font") faces))) + (should (= remap-count 2)))) + +(ert-deftest test-font-config-fontaine-ui-chrome-hooks-are-installed () + "Boundary: profile, theme, and minibuffer changes restore UI typography." + (skip-unless test-font-config--available) + (require 'font-config) + (should (memq 'cj/fontaine-keep-ui-chrome-monospace + fontaine-set-preset-hook)) + (should (memq 'cj/fontaine-keep-ui-chrome-monospace + enable-theme-functions)) + (should (memq 'cj/fontaine-remap-ui-buffer minibuffer-setup-hook))) + +(ert-deftest test-font-config-fontaine-unknown-label-has-no-profile () + "Error: an unknown destination label does not select a preset." + (skip-unless test-font-config--available) + (require 'font-config) + (should-not (cj/fontaine-profile-from-label "Missing profile"))) + +(ert-deftest test-font-config-fontaine-annotation-marks-current-profile () + "Normal: completion marks only the active workflow destination." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((fontaine-current-preset 'writing)) + (should (equal (cj/fontaine-profile-annotation + (cj/fontaine-profile-label 'writing)) + " current")) + (should (equal (cj/fontaine-profile-annotation + (cj/fontaine-profile-label 'coding-m)) + "")))) + +(ert-deftest test-font-config-fontaine-selector-applies-picked-profile () + "Normal: the one-prompt picker maps its complete label before applying." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((picked (cj/fontaine-profile-label 'presentation)) + (applied nil)) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _choices &rest _) picked)) + ((symbol-function 'cj/fontaine-apply-profile) + (lambda (profile) (setq applied profile)))) + (cj/fontaine-select-profile) + (should (eq applied 'presentation))))) + +(ert-deftest test-font-config-fontaine-restores-valid-profile () + "Normal: startup restores a persisted workflow profile." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-restore-latest-preset) + (lambda () 'writing))) + (should (eq (cj/fontaine-restored-or-default-profile) 'writing)))) + +(ert-deftest test-font-config-fontaine-rejects-obsolete-restored-profile () + "Boundary: an old brand or point-size preset falls back to everyday." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-restore-latest-preset) + (lambda () '13-point-font))) + (should (eq (cj/fontaine-restored-or-default-profile) 'everyday)))) + +(ert-deftest test-font-config-fontaine-has-no-per-frame-reset-hook () + "Boundary: creating a daemon frame cannot overwrite the active profile." + (skip-unless test-font-config--available) + (require 'font-config) + (should-not (memq 'cj/apply-font-settings-to-frame + server-after-make-frame-hook)) + (should-not (memq 'cj/cleanup-frame-list delete-frame-functions))) + +(ert-deftest test-font-config-fontaine-apply-records-profile-for-persistence () + "Normal: applying a profile updates Fontaine history before setting it." + (skip-unless test-font-config--available) + (require 'font-config) + (let ((fontaine-preset-history nil) + (applied nil)) + (cl-letf (((symbol-function 'fontaine-set-preset) + (lambda (profile) (setq applied profile)))) + (cj/fontaine-apply-profile 'coding-m) + (should (eq applied 'coding-m)) + (should (equal (car fontaine-preset-history) "coding-m"))))) + +(ert-deftest test-font-config-fontaine-apply-rejects-unknown-profile () + "Error: applying an unknown workflow profile signals a user error." + (skip-unless test-font-config--available) + (require 'font-config) + (cl-letf (((symbol-function 'fontaine-set-preset) + (lambda (_profile) (ert-fail "must not apply")))) + (should-error (cj/fontaine-apply-profile 'missing) :type 'user-error))) + (provide 'test-font-config) ;;; test-font-config.el ends here diff --git a/tests/test-help-utils--arch-wiki-search.el b/tests/test-help-utils--arch-wiki-search.el new file mode 100644 index 00000000..d02dd041 --- /dev/null +++ b/tests/test-help-utils--arch-wiki-search.el @@ -0,0 +1,124 @@ +;;; test-help-utils--arch-wiki-search.el --- Tests for the ArchWiki search guard -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for cj/--arch-wiki-topics and the cj/local-arch-wiki-search command. +;; +;; The bug: the command read "/usr/share/doc/arch-wiki/html/en" with +;; `directory-files' before checking the directory existed. On a machine +;; without arch-wiki-docs -- the exact state the command's own error text is +;; written for -- that signaled file-missing on the first line, so the friendly +;; "Is arch-wiki-docs installed?" message below it was unreachable. The user +;; got a raw Lisp error naming a path instead of the install hint. +;; +;; Two things had to change to make this testable. The directory was +;; hardcoded inside the command, so a test could only ever exercise whatever +;; the developer's own machine happened to have installed; it is now +;; `cj/arch-wiki-html-dir'. And the directory read is now the pure helper +;; cj/--arch-wiki-topics, which takes a directory and returns an alist, so the +;; interesting cases are driven with real temporary directories instead of +;; mocking `directory-files'. +;; +;; Test organization: +;; - Normal Cases: topics found and returned; the command opens the choice +;; - Boundary Cases: empty dir, single topic, a name matching no topic +;; - Error Cases: missing dir returns nil and reports the install hint +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'help-utils) + +(defmacro test-arch-wiki--with-topics (dir-var topics &rest body) + "Bind DIR-VAR to a temp dir holding TOPICS (a list of html basenames). +The directory is removed after BODY." + (declare (indent 2)) + `(let ((,dir-var (make-temp-file "arch-wiki-test" t))) + (unwind-protect + (progn + (dolist (name ,topics) + (write-region "" nil (expand-file-name (concat name ".html") ,dir-var))) + ,@body) + (delete-directory ,dir-var t)))) + +;;; Normal Cases — the pure helper + +(ert-deftest test-help-utils-arch-wiki-topics-lists-html-basenames () + "Normal: each .html file becomes a (basename . fullpath) pair." + (test-arch-wiki--with-topics dir '("Systemd" "Pacman") + (let ((topics (cj/--arch-wiki-topics dir))) + (should (equal '("Pacman" "Systemd") (sort (mapcar #'car topics) #'string<))) + (should (string-suffix-p "Systemd.html" (cdr (assoc "Systemd" topics))))))) + +(ert-deftest test-help-utils-arch-wiki-topics-ignores-non-html () + "Normal: files without the .html extension are not topics." + (test-arch-wiki--with-topics dir '("Systemd") + (write-region "" nil (expand-file-name "README.txt" dir)) + (should (equal '("Systemd") (mapcar #'car (cj/--arch-wiki-topics dir)))))) + +;;; Boundary Cases + +(ert-deftest test-help-utils-arch-wiki-topics-empty-dir-is-nil () + "Boundary: an existing but empty directory yields no topics." + (test-arch-wiki--with-topics dir '() + (should (null (cj/--arch-wiki-topics dir))))) + +(ert-deftest test-help-utils-arch-wiki-topics-single-topic () + "Boundary: one topic returns a one-element alist." + (test-arch-wiki--with-topics dir '("Systemd") + (should (= 1 (length (cj/--arch-wiki-topics dir)))))) + +;;; Error Cases — the missing-install path + +(ert-deftest test-help-utils-arch-wiki-topics-missing-dir-returns-nil () + "Error: an absent directory returns nil rather than signaling file-missing." + (let ((missing (expand-file-name "definitely-absent-arch-wiki" + temporary-file-directory))) + (should-not (file-directory-p missing)) + (should (null (cj/--arch-wiki-topics missing))))) + +(ert-deftest test-help-utils-arch-wiki-search-missing-dir-reports-hint () + "Error: the command reports the install hint and opens nothing." + (let ((cj/arch-wiki-html-dir (expand-file-name "definitely-absent-arch-wiki" + temporary-file-directory)) + (said nil) + (opened nil)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) (setq said (apply #'format fmt args)) nil)) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + ;; Must not signal: this is the case that used to raise file-missing. + (cj/local-arch-wiki-search)) + (should-not opened) + (should (string-match-p "arch-wiki-docs" said)))) + +;;; Normal Cases — the command + +(ert-deftest test-help-utils-arch-wiki-search-opens-chosen-topic () + "Normal: the chosen topic is opened as a file URL in EWW." + (test-arch-wiki--with-topics dir '("Systemd") + (let ((cj/arch-wiki-html-dir dir) + (opened nil)) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "Systemd")) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + (cj/local-arch-wiki-search)) + (should (string-prefix-p "file://" opened)) + (should (string-suffix-p "Systemd.html" opened)) + ;; The opened path is the one in the temp dir, not a system copy. + (should (string-match-p (regexp-quote dir) opened))))) + +(ert-deftest test-help-utils-arch-wiki-search-unknown-topic-opens-nothing () + "Boundary: a name matching no topic reports rather than opening." + (test-arch-wiki--with-topics dir '("Systemd") + (let ((cj/arch-wiki-html-dir dir) + (opened nil)) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "NotATopic")) + ((symbol-function 'message) (lambda (&rest _) nil)) + ((symbol-function 'eww-browse-url) + (lambda (url &rest _) (setq opened url)))) + (cj/local-arch-wiki-search)) + (should-not opened)))) + +(provide 'test-help-utils--arch-wiki-search) +;;; test-help-utils--arch-wiki-search.el ends here diff --git a/tests/test-host-environment--detect-system-timezone.el b/tests/test-host-environment--detect-system-timezone.el index 209283d1..0d76c206 100644 --- a/tests/test-host-environment--detect-system-timezone.el +++ b/tests/test-host-environment--detect-system-timezone.el @@ -17,12 +17,23 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'host-environment) -(ert-deftest test-host-environment-detect-tz-match-localtime-wins () - "Normal: when match-localtime-to-zoneinfo returns a value, that wins." +(ert-deftest test-host-environment-detect-tz-env-wins-without-content-scan () + "Normal: an explicit TZ wins and the exhaustive zoneinfo scan never runs. +The scan reads hundreds of files; it used to run first on every call even +when a cheap O(1) method would answer." (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) - (lambda () "America/Los_Angeles")) + (lambda () (error "content scan should not have run"))) ((symbol-function 'getenv) - (lambda (_ &rest _) (error "TZ should not have been consulted")))) + (lambda (name &rest _) (when (string= name "TZ") "America/Chicago")))) + (should (equal (cj/detect-system-timezone) "America/Chicago")))) + +(ert-deftest test-host-environment-detect-tz-content-scan-is-last-resort () + "Boundary: with every cheap method empty, the content scan still answers." + (cl-letf (((symbol-function 'cj/match-localtime-to-zoneinfo) + (lambda () "America/Los_Angeles")) + ((symbol-function 'getenv) (lambda (&rest _) nil)) + ((symbol-function 'file-exists-p) (lambda (&rest _) nil)) + ((symbol-function 'file-symlink-p) (lambda (&rest _) nil))) (should (equal (cj/detect-system-timezone) "America/Los_Angeles")))) (ert-deftest test-host-environment-detect-tz-env-var-wins-when-match-nil () diff --git a/tests/test-httpd-config--defer.el b/tests/test-httpd-config--defer.el new file mode 100644 index 00000000..1a1fbbed --- /dev/null +++ b/tests/test-httpd-config--defer.el @@ -0,0 +1,34 @@ +;;; test-httpd-config--defer.el --- Tests for httpd-config lazy loading -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins httpd-config's load-time behavior: merely loading the module must +;; not create the www directory (that belongs to the moment simple-httpd +;; actually loads) and must not pull in simple-httpd itself — +;; impatient-mode requires it on demand. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) + +;;; Boundary Cases + +(ert-deftest test-httpd-config-load-creates-no-www-dir () + "Boundary: loading httpd-config does not create www/ in user-emacs-directory." + (let* ((sandbox (make-temp-file "httpd-config-test-" t)) + (user-emacs-directory (file-name-as-directory sandbox))) + (unwind-protect + (progn + (require 'httpd-config) + (should-not (file-directory-p + (expand-file-name "www" user-emacs-directory)))) + (delete-directory sandbox t)))) + +(ert-deftest test-httpd-config-load-does-not-load-simple-httpd () + "Boundary: loading httpd-config leaves simple-httpd unloaded." + (require 'httpd-config) + (should-not (featurep 'simple-httpd))) + +(provide 'test-httpd-config--defer) +;;; test-httpd-config--defer.el ends here diff --git a/tests/test-hugo-config--keymap.el b/tests/test-hugo-config--keymap.el new file mode 100644 index 00000000..0f8df257 --- /dev/null +++ b/tests/test-hugo-config--keymap.el @@ -0,0 +1,71 @@ +;;; test-hugo-config--keymap.el --- Tests for the Hugo prefix keymap -*- lexical-binding: t; -*- + +;;; Commentary: +;; Pins the eight Hugo commands reachable under the "C-; h" prefix. +;; +;; The module used to install these with eight raw `global-set-key' calls plus +;; a hand-written which-key block, writing into the global map directly instead +;; of going through `cj/register-prefix-map' the way its siblings +;; (erc-config, custom-ordering, org-reveal-config) do. These tests were added +;; alongside that conversion so the refactor is checkable: every key must still +;; reach the same command afterward. +;; +;; Test organization: +;; - Normal Cases: each of the eight keys resolves to its command +;; - Boundary Cases: case-distinct pairs stay distinct; the map is a prefix map +;; - Error Cases: an unbound key in the map resolves to nothing +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(provide 'ox-hugo) +(require 'hugo-config) +(require 'keybindings) + +(defconst test-hugo--expected-bindings + '(("n" . cj/hugo-new-post) + ("e" . cj/hugo-export-post) + ("o" . cj/hugo-open-blog-dir) + ("O" . cj/hugo-open-blog-dir-external) + ("d" . cj/hugo-open-draft) + ("D" . cj/hugo-toggle-draft) + ("p" . cj/hugo-preview) + ("P" . cj/hugo-publish)) + "Every key the Hugo prefix map must carry, and the command it runs.") + +;;; Normal Cases + +(ert-deftest test-hugo-config-keymap-binds-every-command () + "Normal: each Hugo key resolves to its command inside the prefix map." + (dolist (pair test-hugo--expected-bindings) + (should (eq (cdr pair) (keymap-lookup cj/hugo-keymap (car pair)))))) + +(ert-deftest test-hugo-config-keymap-registered-under-custom-prefix () + "Normal: the map is reachable at \"h\" within `cj/custom-keymap'." + (should (eq cj/hugo-keymap (keymap-lookup cj/custom-keymap "h")))) + +;;; Boundary Cases + +(ert-deftest test-hugo-config-keymap-case-pairs-stay-distinct () + "Boundary: the shifted variants run different commands than their lowercase +counterparts, which a case-folding binding would silently collapse." + (should-not (eq (keymap-lookup cj/hugo-keymap "o") + (keymap-lookup cj/hugo-keymap "O"))) + (should-not (eq (keymap-lookup cj/hugo-keymap "d") + (keymap-lookup cj/hugo-keymap "D"))) + (should-not (eq (keymap-lookup cj/hugo-keymap "p") + (keymap-lookup cj/hugo-keymap "P")))) + +(ert-deftest test-hugo-config-keymap-is-a-keymap () + "Boundary: the value registered as a prefix is an actual keymap." + (should (keymapp cj/hugo-keymap))) + +;;; Error Cases + +(ert-deftest test-hugo-config-keymap-unbound-key-is-nil () + "Error: a key the map does not define resolves to nothing." + (should-not (keymap-lookup cj/hugo-keymap "z"))) + +(provide 'test-hugo-config--keymap) +;;; test-hugo-config--keymap.el ends here diff --git a/tests/test-integration-calendar-sync-timezone.el b/tests/test-integration-calendar-sync-timezone.el index 304d3233..a3f65146 100644 --- a/tests/test-integration-calendar-sync-timezone.el +++ b/tests/test-integration-calendar-sync-timezone.el @@ -187,12 +187,21 @@ Components integrated: Validates: - Org timestamp format is correct (<YYYY-MM-DD Day HH:MM-HH:MM>) -- Hour in timestamp is the converted local hour" - (let* ((source-time (list 2026 2 2 19 0)) +- Hour in timestamp is the converted local hour + +The date is generated relative to now because `calendar-sync--parse-ics' +drops events outside `calendar-sync--get-date-range' (today minus +`calendar-sync-past-months', plus `calendar-sync-future-months'). This test +used a hardcoded 2026-02-02, which sat inside that window when it was written +and fell out of it once three months had passed -- the event was filtered +before rendering and the assertion failed against an empty org buffer. The +sibling tests survived hardcoded dates only because they call +`calendar-sync--parse-event' directly, which applies no range filter." + (let* ((source-time (test-calendar-sync-time-days-from-now 7 19 0)) (ics (test-integration-tz--make-ics-with-tzid-event "Test Event" source-time "Europe/Lisbon")) - (expected-local (test-calendar-sync-convert-tz-via-date - 2026 2 2 19 0 "Europe/Lisbon")) + (expected-local (apply #'test-calendar-sync-convert-tz-via-date + (append source-time (list "Europe/Lisbon")))) (expected-hour (nth 3 expected-local)) (org-output (calendar-sync--parse-ics ics))) (should org-output) diff --git a/tests/test-integration-recording-device-workflow.el b/tests/test-integration-recording-device-workflow.el index 3ef631f3..27ffac56 100644 --- a/tests/test-integration-recording-device-workflow.el +++ b/tests/test-integration-recording-device-workflow.el @@ -1,26 +1,24 @@ ;;; test-integration-recording-device-workflow.el --- Integration tests for recording device workflow -*- lexical-binding: t; -*- ;;; Commentary: -;; Integration tests covering the complete device detection and grouping workflow. -;; -;; This tests the full pipeline from raw pactl output through parsing, grouping, -;; and friendly name assignment. The workflow enables users to select audio devices -;; for recording calls/meetings. +;; Integration test covering the device detection path that recording actually +;; uses: raw pactl output through parsing and into friendly state names. ;; ;; Components integrated: ;; - cj/recording--parse-pactl-output (parse raw pactl output into structured data) -;; - cj/recording-parse-sources (shell command wrapper) -;; - cj/recording-group-devices-by-hardware (group inputs/monitors by device) +;; - cj/recording-parse-sources (shell command wrapper, MOCKED at +;; shell-command-to-string so no pactl runs) ;; - cj/recording-friendly-state (convert technical state names) -;; - Bluetooth MAC address normalization (colons → underscores) -;; - Device name pattern matching (USB, PCI, Bluetooth) -;; - Friendly name assignment (user-facing device names) ;; ;; Critical integration points: -;; - Parse output must produce data that group-devices can process -;; - Bluetooth MAC normalization must work across parse→group boundary -;; - Incomplete devices (only mic OR only monitor) must be filtered -;; - Friendly names must correctly identify device types +;; - Parse output must carry device state through to the friendly-name conversion +;; +;; This file once covered a parse-to-group pipeline as well. That half tested +;; cj/recording-group-devices-by-hardware, a second device-grouping +;; implementation nothing ever called -- cj/recording-select-device is the live +;; selection path and reaches parse-sources directly. The function and its +;; tests were removed rather than left as coverage that proved an unused code +;; path worked. ;;; Code: @@ -46,58 +44,6 @@ ;;; Normal Cases - Complete Workflow -(ert-deftest test-integration-recording-device-workflow-parse-to-group-all-devices () - "Test complete workflow from pactl output to grouped devices. - -When pactl output contains all three device types (built-in, USB, Bluetooth), -the workflow should parse, group, and assign friendly names to all devices. - -Components integrated: -- cj/recording--parse-pactl-output (parsing) -- cj/recording-group-devices-by-hardware (grouping + MAC normalization) -- Device pattern matching (USB/PCI/Bluetooth detection) -- Friendly name assignment - -Validates: -- All three device types are detected -- Bluetooth MAC addresses normalized (colons → underscores) -- Each device has both mic and monitor -- Friendly names correctly assigned -- Complete data flow: raw output → parsed list → grouped pairs" - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - ;; Test parse step - (let ((parsed (cj/recording-parse-sources))) - (should (= 6 (length parsed))) - - ;; Test group step (receives parsed data) - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 3 (length grouped))) - - ;; Validate built-in device - (let ((built-in (assoc "Built-in Audio" grouped))) - (should built-in) - (should (string-prefix-p "alsa_input.pci" (cadr built-in))) - (should (string-prefix-p "alsa_output.pci" (cddr built-in)))) - - ;; Validate USB device - (let ((usb (assoc "Jabra SPEAK 510 USB" grouped))) - (should usb) - (should (string-match-p "Jabra" (cadr usb))) - (should (string-match-p "Jabra" (cddr usb)))) - - ;; Validate Bluetooth device (CRITICAL: MAC normalization) - (let ((bluetooth (assoc "Bluetooth Headset" grouped))) - (should bluetooth) - ;; Input has colons - (should (string-match-p "00:1B:66:C0:91:6D" (cadr bluetooth))) - ;; Output has underscores - (should (string-match-p "00_1B_66_C0_91_6D" (cddr bluetooth))) - ;; But they're grouped together! - (should (equal "bluez_input.00:1B:66:C0:91:6D" (cadr bluetooth))) - (should (equal "bluez_output.00_1B_66_C0_91_6D.1.monitor" (cddr bluetooth))))))))) - (ert-deftest test-integration-recording-device-workflow-friendly-states-in-list () "Test that friendly state names appear in device list output. @@ -128,105 +74,5 @@ Validates: ;;; Boundary Cases - Incomplete Devices -(ert-deftest test-integration-recording-device-workflow-incomplete-devices-filtered () - "Test that devices with only mic OR only monitor are filtered out. - -For call recording, we need BOTH mic and monitor from the same device. -Incomplete devices should not appear in the grouped output. - -Components integrated: -- cj/recording-parse-sources (parsing all devices) -- cj/recording-group-devices-by-hardware (filtering incomplete pairs) - -Validates: -- Device with only mic is filtered -- Device with only monitor is filtered -- Only complete devices (both mic and monitor) are returned -- Filtering happens at group stage, not parse stage" - (let ((output (concat - ;; Complete device - "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - "49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - ;; Incomplete: USB mic with no monitor - "100\talsa_input.usb-device.mono-fallback\tPipeWire\ts16le 1ch 16000Hz\tSUSPENDED\n" - ;; Incomplete: Bluetooth monitor with no mic - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - ;; Parse sees all 4 devices - (let ((parsed (cj/recording-parse-sources))) - (should (= 4 (length parsed))) - - ;; Group returns only 1 complete device - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 1 (length grouped))) - (should (equal "Built-in Audio" (caar grouped)))))))) - -;;; Edge Cases - Bluetooth MAC Normalization - -(ert-deftest test-integration-recording-device-workflow-bluetooth-mac-variations () - "Test Bluetooth MAC normalization with different formats. - -Bluetooth devices use colons in input names but underscores in output names. -The grouping must normalize these to match devices correctly. - -Components integrated: -- cj/recording-parse-sources (preserves original MAC format) -- cj/recording-group-devices-by-hardware (normalizes MAC for matching) -- Base name extraction (regex patterns) -- MAC address transformation (underscores → colons) - -Validates: -- Input with colons (bluez_input.AA:BB:CC:DD:EE:FF) parsed correctly -- Output with underscores (bluez_output.AA_BB_CC_DD_EE_FF) parsed correctly -- Normalization happens during grouping -- Devices paired despite format difference -- Original device names preserved (not mutated)" - (let ((output (concat - "79\tbluez_input.11:22:33:44:55:66\tPipeWire\tfloat32le 1ch 48000Hz\tSUSPENDED\n" - "81\tbluez_output.11_22_33_44_55_66.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((parsed (cj/recording-parse-sources))) - ;; Original formats preserved in parse - (should (string-match-p "11:22:33" (caar parsed))) - (should (string-match-p "11_22_33" (caadr parsed))) - - ;; But grouping matches them - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (= 1 (length grouped))) - (should (equal "Bluetooth Headset" (caar grouped))) - ;; Original names preserved - (should (equal "bluez_input.11:22:33:44:55:66" (cadar grouped))) - (should (equal "bluez_output.11_22_33_44_55_66.1.monitor" (cddar grouped)))))))) - -;;; Error Cases - Malformed Data - -(ert-deftest test-integration-recording-device-workflow-malformed-output-handled () - "Test that malformed pactl output is handled gracefully. - -When pactl output is malformed or unparseable, the workflow should not crash. -It should return empty results at appropriate stages. - -Components integrated: -- cj/recording--parse-pactl-output (malformed line handling) -- cj/recording-group-devices-by-hardware (empty input handling) - -Validates: -- Malformed lines are silently skipped during parse -- Empty parse results don't crash grouping -- Workflow degrades gracefully -- No exceptions thrown" - (let ((output (test-load-fixture "pactl-output-malformed.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((parsed (cj/recording-parse-sources))) - ;; Malformed output produces empty parse - (should (null parsed)) - - ;; Empty parse produces empty grouping (no crash) - (let ((grouped (cj/recording-group-devices-by-hardware))) - (should (null grouped))))))) - (provide 'test-integration-recording-device-workflow) ;;; test-integration-recording-device-workflow.el ends here diff --git a/tests/test-integration-recording-toggle-workflow.el b/tests/test-integration-recording-toggle-workflow.el index e73ef87e..6258fc58 100644 --- a/tests/test-integration-recording-toggle-workflow.el +++ b/tests/test-integration-recording-toggle-workflow.el @@ -43,6 +43,24 @@ ;;; Setup and Teardown +(defun test-integration-toggle--fake-pactl (cmd &rest _) + "Answer pactl queries for CMD from fixture devices, never the real machine. + +`cj/recording-get-devices' runs `cj/recording--validate-system-audio', which +shells out to pactl, decides a fixture device name is not a real source, and +\"auto-fixes\" the configured device to the default sink's monitor. Left +unmocked that clobbers the test's device with whatever hardware the developer +has plugged in, so the assertions compare against a JDS Labs DAC rather than +the fixture. Answering at the shell boundary keeps the real validation logic +under test while the machine stays out of it." + (cond + ((string-match-p "get-default-sink" cmd) "fixture-sink\n") + ((string-match-p "list sources short" cmd) + "0\ttest-monitor\tmodule-x\ts16le 2ch 44100Hz\tIDLE\n1\tcached-monitor\tmodule-x\ts16le 2ch 44100Hz\tIDLE\n") + ((string-match-p "list sinks short" cmd) + "0\tfixture-sink\tmodule-x\ts16le 2ch 44100Hz\tRUNNING\n") + (t ""))) + (defun test-integration-toggle-setup () "Reset all variables before each test." (setq cj/video-recording-ffmpeg-process nil) @@ -102,6 +120,8 @@ Validates: (setq setup-called t) (setq cj/recording-mic-device "test-mic") (setq cj/recording-system-device "test-monitor"))) + ((symbol-function 'shell-command-to-string) + #'test-integration-toggle--fake-pactl) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ((symbol-function 'start-process-shell-command) @@ -168,6 +188,8 @@ Validates: (ffmpeg-cmd nil)) (cl-letf (((symbol-function 'cj/recording-quick-setup) (lambda () (setq setup-called t))) + ((symbol-function 'shell-command-to-string) + #'test-integration-toggle--fake-pactl) ((symbol-function 'file-directory-p) (lambda (_dir) t)) ((symbol-function 'start-process-shell-command) diff --git a/tests/test-integration-recurring-events.el b/tests/test-integration-recurring-events.el index 3cae1a20..8339d167 100644 --- a/tests/test-integration-recurring-events.el +++ b/tests/test-integration-recurring-events.el @@ -34,53 +34,78 @@ ;;; Test Data -(defconst test-integration-recurring-events--weekly-ics - "BEGIN:VCALENDAR -VERSION:2.0 -PRODID:-//Test//Test//EN -BEGIN:VEVENT -DTSTART;TZID=America/Chicago:20251118T103000 -DTEND;TZID=America/Chicago:20251118T110000 -RRULE:FREQ=WEEKLY;BYDAY=SA -SUMMARY:GTFO -UID:test-weekly@example.com -END:VEVENT -END:VCALENDAR" - "Test ICS with weekly recurring event (GTFO use case).") +;; Fixtures that reach `calendar-sync--parse-ics' must carry dates relative to +;; now. That entry point drops any event outside +;; `calendar-sync--get-date-range' (today minus `calendar-sync-past-months', +;; plus `calendar-sync-future-months'), so a hardcoded DTSTART works only until +;; the rolling window moves past it. Three tests here rotted exactly that way: +;; their November-2025 fixtures aged out of the window, the events were filtered +;; before rendering, and the assertions failed against an empty org buffer. The +;; weekly fixtures survived only because an unbounded RRULE keeps generating +;; occurrences into the window no matter how old its DTSTART is. +;; +;; Fixtures given straight to `calendar-sync--parse-event' can stay static -- +;; that path applies no range filter. -(defconst test-integration-recurring-events--daily-with-count-ics - "BEGIN:VCALENDAR +(defun test-integration-recurring-events--ics-stamp (offset-days hour minute) + "Return an ICS UTC datetime OFFSET-DAYS from today at HOUR:MINUTE." + (let ((d (test-calendar-sync-time-days-from-now offset-days hour minute))) + (format "%04d%02d%02dT%02d%02d00Z" (nth 0 d) (nth 1 d) (nth 2 d) hour minute))) + +(defun test-integration-recurring-events--daily-with-count-ics () + "ICS with a COUNT=5 daily series starting inside the sync window." + (format "BEGIN:VCALENDAR VERSION:2.0 PRODID:-//Test//Test//EN BEGIN:VEVENT -DTSTART:20251120T090000Z -DTEND:20251120T100000Z +DTSTART:%s +DTEND:%s RRULE:FREQ=DAILY;COUNT=5 SUMMARY:Daily Standup UID:test-daily@example.com END:VEVENT END:VCALENDAR" - "Test ICS with daily recurring event limited by COUNT.") + (test-integration-recurring-events--ics-stamp 2 9 0) + (test-integration-recurring-events--ics-stamp 2 10 0))) -(defconst test-integration-recurring-events--mixed-ics - "BEGIN:VCALENDAR +(defun test-integration-recurring-events--mixed-ics () + "ICS mixing a one-time event and a recurring one, both inside the window." + (format "BEGIN:VCALENDAR VERSION:2.0 PRODID:-//Test//Test//EN BEGIN:VEVENT -DTSTART:20251125T140000Z -DTEND:20251125T150000Z +DTSTART:%s +DTEND:%s SUMMARY:One-time Meeting UID:test-onetime@example.com END:VEVENT BEGIN:VEVENT -DTSTART;TZID=America/Chicago:20251201T093000 -DTEND;TZID=America/Chicago:20251201T103000 +DTSTART;TZID=America/Chicago:%s +DTEND;TZID=America/Chicago:%s RRULE:FREQ=WEEKLY;BYDAY=MO,WE,FR SUMMARY:Recurring Standup UID:test-recurring@example.com END:VEVENT END:VCALENDAR" - "Test ICS with mix of recurring and non-recurring events.") + (test-integration-recurring-events--ics-stamp 3 14 0) + (test-integration-recurring-events--ics-stamp 3 15 0) + ;; TZID form carries no Z suffix. + (string-remove-suffix "Z" (test-integration-recurring-events--ics-stamp 5 9 30)) + (string-remove-suffix "Z" (test-integration-recurring-events--ics-stamp 5 10 30)))) + +(defconst test-integration-recurring-events--weekly-ics + "BEGIN:VCALENDAR +VERSION:2.0 +PRODID:-//Test//Test//EN +BEGIN:VEVENT +DTSTART;TZID=America/Chicago:20251118T103000 +DTEND;TZID=America/Chicago:20251118T110000 +RRULE:FREQ=WEEKLY;BYDAY=SA +SUMMARY:GTFO +UID:test-weekly@example.com +END:VEVENT +END:VCALENDAR" + "Test ICS with weekly recurring event (GTFO use case).") ;;; Normal Cases - Complete Workflow @@ -133,7 +158,7 @@ Validates: - Exactly 5 occurrences created" (test-integration-recurring-events-setup) (unwind-protect - (let ((org-output (calendar-sync--parse-ics test-integration-recurring-events--daily-with-count-ics))) + (let ((org-output (calendar-sync--parse-ics (test-integration-recurring-events--daily-with-count-ics)))) (should (stringp org-output)) ;; Should generate exactly 5 Daily Standup entries @@ -160,7 +185,7 @@ Validates: - Events are sorted chronologically" (test-integration-recurring-events-setup) (unwind-protect - (let ((org-output (calendar-sync--parse-ics test-integration-recurring-events--mixed-ics))) + (let ((org-output (calendar-sync--parse-ics (test-integration-recurring-events--mixed-ics)))) (should (stringp org-output)) ;; Should have one-time meeting @@ -197,12 +222,19 @@ Validates: (test-integration-recurring-events-setup) (unwind-protect (let* ((org-output (calendar-sync--parse-ics test-integration-recurring-events--weekly-ics)) - (now (current-time)) - (three-months-ago (time-subtract now (* 90 24 3600))) - (twelve-months-future (time-add now (* 365 24 3600)))) + (range (calendar-sync--get-date-range)) + (window-start (nth 0 range)) + (window-end (nth 1 range))) (should (stringp org-output)) - ;; Parse all dates from output + ;; Every emitted occurrence must fall within the pipeline's own window + ;; (-3/+12 calendar months at day granularity, from + ;; `calendar-sync--get-date-range'). Asserting against that boundary, + ;; rather than a hand-rolled now +/- fixed-day approximation, keeps the + ;; test robust on every date: a valid boundary occurrence stamped at + ;; midnight used to read as out-of-range against a now-90d bound taken + ;; at the current clock time, so the test failed or passed depending on + ;; the day it ran. (with-temp-buffer (insert org-output) (goto-char (point-min)) @@ -212,9 +244,9 @@ Validates: (month (string-to-number (match-string 2))) (day (string-to-number (match-string 3))) (event-time (encode-time 0 0 0 day month year))) - ;; All dates should be within window - (when (or (time-less-p event-time three-months-ago) - (time-less-p twelve-months-future event-time)) + ;; Within [window-start, window-end] inclusive. + (when (or (time-less-p event-time window-start) + (time-less-p window-end event-time)) (setq all-dates-in-range nil)))) (should all-dates-in-range)))) (test-integration-recurring-events-teardown))) @@ -291,18 +323,21 @@ Validates: - Valid events still processed" (test-integration-recurring-events-setup) (unwind-protect - (let* ((incomplete-ics "BEGIN:VCALENDAR + (let* ((incomplete-ics (format "BEGIN:VCALENDAR VERSION:2.0 BEGIN:VEVENT -DTSTART:20251201T100000Z +DTSTART:%s RRULE:FREQ=DAILY;COUNT=2 END:VEVENT BEGIN:VEVENT SUMMARY:Valid Event -DTSTART:20251201T110000Z -DTEND:20251201T120000Z +DTSTART:%s +DTEND:%s END:VEVENT -END:VCALENDAR") +END:VCALENDAR" + (test-integration-recurring-events--ics-stamp 4 10 0) + (test-integration-recurring-events--ics-stamp 4 11 0) + (test-integration-recurring-events--ics-stamp 4 12 0))) (org-output (calendar-sync--parse-ics incomplete-ics))) ;; Should still generate output (for valid event) (should (stringp org-output)) diff --git a/tests/test-jumper.el b/tests/test-jumper.el index fa65d3f4..638f2aa2 100644 --- a/tests/test-jumper.el +++ b/tests/test-jumper.el @@ -348,5 +348,30 @@ (should (string-match-p "test line" formatted)))) (test-jumper-teardown)) +;;; Empty completing-read input (vertico-less UI can return "") + +(ert-deftest test-jumper-jump-empty-choice-signals-user-error () + "Error: empty input at the jump prompt gives a user-error, not a crash. +An unmatched choice makes (cdr (assoc ...)) nil, which used to flow into +the index arithmetic and signal wrong-type-argument." + (let ((jumper--next-index 2)) + (cl-letf (((symbol-function 'jumper--location-candidates) + (lambda () '(("[0] here" . 0) ("[1] there" . 1)))) + ((symbol-function 'get-register) (lambda (_r) nil)) + ((symbol-function 'completing-read) (lambda (&rest _) ""))) + (should-error (jumper-jump-to-location) :type 'user-error)))) + +(ert-deftest test-jumper-remove-empty-choice-cancels () + "Boundary: empty input at the remove prompt cancels instead of crashing." + (let ((jumper--next-index 2) + removed) + (cl-letf (((symbol-function 'jumper--location-candidates) + (lambda () '(("[0] here" . 0) ("[1] there" . 1)))) + ((symbol-function 'completing-read) (lambda (&rest _) "")) + ((symbol-function 'jumper--reorder-registers) + (lambda (_i) (setq removed t)))) + (jumper-remove-location) + (should-not removed)))) + (provide 'test-jumper) ;;; test-jumper.el ends here diff --git a/tests/test-keyboard-compat-setup.el b/tests/test-keyboard-compat-setup.el index 1c5cd434..a23e24e1 100644 --- a/tests/test-keyboard-compat-setup.el +++ b/tests/test-keyboard-compat-setup.el @@ -61,6 +61,14 @@ string can return a meta-prefix event count rather than nil.)" (cj/keyboard-compat-terminal-setup) (should (equal input-decode-map (make-sparse-keymap))))) +(ert-deftest test-keyboard-compat-terminal-setup-on-tty-setup-hook () + "Normal: terminal setup is registered on `tty-setup-hook', which runs for each +new tty frame. `input-decode-map' is terminal-local, so `emacs-startup-hook' +\(once, at daemon start, with no tty) leaves every later `emacsclient -t' frame +without the arrow-key decodings. The GUI half already frame-scopes itself." + (should (memq 'cj/keyboard-compat-terminal-setup tty-setup-hook)) + (should-not (memq 'cj/keyboard-compat-terminal-setup emacs-startup-hook))) + ;; -------------------------- cj/keyboard-compat-gui-setup --------------------- (defmacro test-kbc--gui (gui-p &rest body) @@ -71,18 +79,20 @@ string can return a meta-prefix event count rather than nil.)" ,@body))) (defconst test-kbc--meta-shift-letters - '(?o ?m ?y ?f ?w ?e ?l ?r ?v ?h ?t ?z ?u ?d ?i ?c ?b ?k) - "The 18 letters whose M-<UPPER> form is translated to M-S-<lower> in GUI mode.") + '(?o ?m ?y ?f ?w ?e ?l ?r ?v ?h ?t ?z ?u ?d ?i ?c ?b) + "The 17 letters whose M-<UPPER> form is translated to M-S-<lower> in GUI mode.") (ert-deftest test-keyboard-compat-gui-setup-translates-spot-checks () - "Normal: in GUI mode, M-O -> M-S-o and M-K -> M-S-k (sampled)." + "Normal: in GUI mode, M-O -> M-S-o and M-B -> M-S-b (sampled). +M-K is no longer translated: show-kill-ring, its only consumer, was retired." (test-kbc--gui t (cj/keyboard-compat-gui-setup) (should (equal (lookup-key key-translation-map (kbd "M-O")) (kbd "M-S-o"))) - (should (equal (lookup-key key-translation-map (kbd "M-K")) (kbd "M-S-k"))) - (should (equal (lookup-key key-translation-map (kbd "M-D")) (kbd "M-S-d"))))) + (should (equal (lookup-key key-translation-map (kbd "M-B")) (kbd "M-S-b"))) + (should (equal (lookup-key key-translation-map (kbd "M-D")) (kbd "M-S-d"))) + (should-not (lookup-key key-translation-map (kbd "M-K"))))) -(ert-deftest test-keyboard-compat-gui-setup-translates-all-eighteen () +(ert-deftest test-keyboard-compat-gui-setup-translates-all-seventeen () "Normal: every documented M-<UPPER> maps to its M-S-<lower> form." (test-kbc--gui t (cj/keyboard-compat-gui-setup) diff --git a/tests/test-ledger-config.el b/tests/test-ledger-config.el new file mode 100644 index 00000000..5224c184 --- /dev/null +++ b/tests/test-ledger-config.el @@ -0,0 +1,70 @@ +;;; test-ledger-config.el --- Characterization tests for ledger-config -*- lexical-binding: t; -*- + +;;; Commentary: +;; Captures the behavior ledger-config.el has today, before any guardrail work +;; changes it. See docs/design/2026-07-10-ledger-config-audit.org for the audit +;; these tests pin. +;; +;; The clean-on-save helpers are defined in the `use-package' `:preface', which +;; use-package emits unconditionally, so they exist under `make test' even though +;; ledger-mode itself never loads there (no `package-initialize' in the test run). +;; +;; `ledger-mode-clean-buffer' is stubbed: it is the boundary this config delegates +;; to, and it rewrites the whole buffer. What these tests pin is whether our hook +;; calls it, not what it does. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'ledger-config) + +(ert-deftest test-ledger-config-clean-before-save-cleans-when-enabled () + "Normal: with `cj/ledger-clean-on-save' set, the save hook cleans the buffer." + (let ((called 0) + (cj/ledger-clean-on-save t)) + (cl-letf (((symbol-function 'ledger-mode-clean-buffer) + (lambda (&rest _) (setq called (1+ called))))) + (cj/ledger--clean-before-save)) + (should (= 1 called)))) + +(ert-deftest test-ledger-config-clean-before-save-skips-when-disabled () + "Boundary: with `cj/ledger-clean-on-save' nil, the save hook does nothing." + (let ((called 0) + (cj/ledger-clean-on-save nil)) + (cl-letf (((symbol-function 'ledger-mode-clean-buffer) + (lambda (&rest _) (setq called (1+ called))))) + (cj/ledger--clean-before-save)) + (should (= 0 called)))) + +(ert-deftest test-ledger-config-clean-before-save-demotes-errors () + "Error: a failing clean does not signal, so the file still saves. +This is the current contract. It also means a clean that fails partway +leaves the buffer in whatever state it reached, because nothing rolls back." + (let ((cj/ledger-clean-on-save t) + (inhibit-message t)) + (cl-letf (((symbol-function 'ledger-mode-clean-buffer) + (lambda (&rest _) (error "boom")))) + (should (progn (cj/ledger--clean-before-save) t))))) + +(ert-deftest test-ledger-config-enable-clean-on-save-is-buffer-local () + "Normal: the hook installs buffer-locally, not globally." + (let ((global-before (default-value 'before-save-hook))) + (with-temp-buffer + (cj/ledger--enable-clean-on-save) + (should (memq #'cj/ledger--clean-before-save before-save-hook)) + (should-not (memq #'cj/ledger--clean-before-save + (default-value 'before-save-hook)))) + (should (equal global-before (default-value 'before-save-hook))))) + +(ert-deftest test-ledger-config-clean-on-save-defaults-on () + "Normal: clean-on-save ships enabled. +Pinned because the audit questions whether a whole-buffer sort belongs on +every save of a financial file. If that default flips, this test should +fail and be updated deliberately." + (should (eq t (default-value 'cj/ledger-clean-on-save)))) + +(provide 'test-ledger-config) +;;; test-ledger-config.el ends here diff --git a/tests/test-local-repository--car-member.el b/tests/test-local-repository--car-member.el deleted file mode 100644 index 30ae58c6..00000000 --- a/tests/test-local-repository--car-member.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; test-local-repository--car-member.el --- Tests for localrepo--car-member -*- lexical-binding: t -*- - -;;; Commentary: -;; Tests for `localrepo--car-member' in local-repository.el — the predicate -;; localrepo-initialize uses to check whether an archive id is already -;; registered in package-archives / package-archive-priorities. - -;;; Code: - -(require 'ert) -(require 'local-repository) - -;;; Normal Cases - -(ert-deftest test-local-repository-localrepo--car-member-found () - "Normal: VALUE present as a car returns the matching tail (non-nil)." - (should (equal (localrepo--car-member 'b '((a . 1) (b . 2) (c . 3))) - '(b c)))) - -(ert-deftest test-local-repository-localrepo--car-member-not-found () - "Normal: VALUE absent from every car returns nil." - (should-not (localrepo--car-member 'z '((a . 1) (b . 2))))) - -(ert-deftest test-local-repository-localrepo--car-member-string-car () - "Normal: car comparison uses `equal', so string keys match by value." - (should (localrepo--car-member "localrepo" - '(("gnu" . "url1") ("localrepo" . "url2"))))) - -;;; Boundary Cases - -(ert-deftest test-local-repository-localrepo--car-member-empty-list () - "Boundary: an empty list never matches." - (should-not (localrepo--car-member 'a nil))) - -(ert-deftest test-local-repository-localrepo--car-member-single-match () - "Boundary: a single-element list whose car matches returns non-nil." - (should (localrepo--car-member 'only '((only . 1))))) - -(ert-deftest test-local-repository-localrepo--car-member-single-no-match () - "Boundary: a single-element list whose car differs returns nil." - (should-not (localrepo--car-member 'x '((only . 1))))) - -(ert-deftest test-local-repository-localrepo--car-member-nil-value-with-nil-car () - "Boundary: a nil VALUE matches a cons whose car is nil." - (should (localrepo--car-member nil '((nil . 1) (a . 2))))) - -(ert-deftest test-local-repository-localrepo--car-member-nil-value-no-nil-car () - "Boundary: a nil VALUE with no nil car returns nil." - (should-not (localrepo--car-member nil '((a . 1) (b . 2))))) - -;;; Error Cases - -(ert-deftest test-local-repository-localrepo--car-member-non-cons-element () - "Error: a non-cons element makes `car' signal wrong-type-argument." - (should-error (localrepo--car-member 'x '(1 2)) :type 'wrong-type-argument)) - -(provide 'test-local-repository--car-member) -;;; test-local-repository--car-member.el ends here diff --git a/tests/test-local-repository.el b/tests/test-local-repository.el new file mode 100644 index 00000000..132f8dc4 --- /dev/null +++ b/tests/test-local-repository.el @@ -0,0 +1,32 @@ +;;; test-local-repository.el --- Tests for the local-repository update command -*- lexical-binding: t; -*- + +;;; Commentary: +;; `cj/update-localrepo-repository' refreshes the checked-in local package +;; archive at `localrepo-location' (owned by early-init.el) via elpa-mirror. +;; The elpa-mirror call is mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'local-repository) + +;; localrepo-location is a defconst in early-init.el, which `make test' never +;; loads. Declare it special here so the `let' below binds it dynamically and +;; the module reads that value. +(defvar localrepo-location nil) + +(ert-deftest test-local-repository-update-targets-early-init-location () + "Normal: the mirror update targets `localrepo-location', the single archive +path early-init.el owns, not a divergent module-local copy." + (let ((localrepo-location "/tmp/test-localrepo/") + (captured nil)) + (cl-letf (((symbol-function 'elpamr-create-mirror-for-installed) + (lambda (dir &rest _) (setq captured dir)))) + (cj/update-localrepo-repository) + (should (equal captured "/tmp/test-localrepo/"))))) + +(provide 'test-local-repository) +;;; test-local-repository.el ends here diff --git a/tests/test-lorem-optimum.el b/tests/test-lorem-optimum.el index f928c972..b7d97a8e 100644 --- a/tests/test-lorem-optimum.el +++ b/tests/test-lorem-optimum.el @@ -253,5 +253,26 @@ an empty string, not an error." (let ((cj/lipsum-chain (cj/markov-chain-create))) (should (equal "" (cj/lipsum-title))))) +;;; cj/lipsum entry point + +(ert-deftest test-lipsum-returns-string-with-populated-chain () + "Normal: cj/lipsum returns a non-empty string when the chain is trained." + (let ((cj/lipsum-chain + (test-learn "Lorem ipsum dolor sit amet consectetur adipiscing elit"))) + (let ((result (cj/lipsum 5))) + (should (stringp result)) + (should (> (length result) 0))))) + +(ert-deftest test-lipsum-empty-chain-signals-user-error () + "Error: cj/lipsum on an empty chain signals a user-error naming the fix, +rather than returning nil and letting cj/lipsum-insert do (insert nil), +which raises a cryptic wrong-type error far from the cause." + (let ((cj/lipsum-chain (cj/markov-chain-create))) + (should-error (cj/lipsum 5) :type 'user-error))) + +(ert-deftest test-lipsum-is-interactive-command () + "Normal: cj/lipsum is a command, as its Commentary (M-x cj/lipsum) advertises." + (should (commandp 'cj/lipsum))) + (provide 'test-lorem-optimum) ;;; test-lorem-optimum.el ends here diff --git a/tests/test-mail-config--account-search-queries.el b/tests/test-mail-config--account-search-queries.el index 9f1b6b3e..02a74692 100644 --- a/tests/test-mail-config--account-search-queries.el +++ b/tests/test-mail-config--account-search-queries.el @@ -38,9 +38,12 @@ (ert-deftest test-mail-make-account-map-closures-capture-distinct-queries () "Normal: each binding runs its own account-scoped search (no closure leak). -mu4e-search is mocked to capture the query each command passes." +mu4e-search is mocked to capture the query each command passes; require is +mocked so the commands' mu4e load never pulls the real package in batch." (let ((searched '())) - (cl-letf (((symbol-function 'mu4e-search) + (cl-letf (((symbol-function 'require) + (lambda (feature &rest _) feature)) + ((symbol-function 'mu4e-search) (lambda (q) (push q searched)))) (let ((map (cj/--mail-make-account-map "dmail"))) (funcall (keymap-lookup map "i")) @@ -49,5 +52,20 @@ mu4e-search is mocked to capture the query each command passes." (should (member "maildir:/dmail/INBOX AND flag:unread AND NOT flag:trashed" searched)))) +(ert-deftest test-mail-make-account-map-loads-mu4e-before-search () + "Error: a nav command loads mu4e before it calls `mu4e-search'. +The C-; e maps register eagerly at startup, but `mu4e-search' carries no +autoload cookie, so a nav key pressed before mu4e's first launch signaled +void-function. The command must require mu4e first, then search." + (let ((events '())) + (cl-letf (((symbol-function 'require) + (lambda (feature &rest _) (push (list :require feature) events) feature)) + ((symbol-function 'mu4e-search) + (lambda (q) (push (list :search q) events)))) + (funcall (keymap-lookup (cj/--mail-make-account-map "cmail") "i"))) + (should (equal (nreverse events) + '((:require mu4e) + (:search "maildir:/cmail/INBOX")))))) + (provide 'test-mail-config--account-search-queries) ;;; test-mail-config--account-search-queries.el ends here diff --git a/tests/test-mail-config-transport.el b/tests/test-mail-config-transport.el index 0240102a..9329ac70 100644 --- a/tests/test-mail-config-transport.el +++ b/tests/test-mail-config-transport.el @@ -66,6 +66,23 @@ EXECUTABLES is an alist of program name strings to executable paths." (should (equal test-mail-config--warnings '((mail-config . "msmtp not found; SMTP mail sending unavailable"))))))) +(ert-deftest test-mail-config-transport-msmtp-missing-sets-descriptive-fallback () + "Error: with msmtp absent, the send functions get a descriptive fallback. +The old behavior left `message-send-mail-function' nil (the top-level defvar +pre-empts message.el's default), so the first send died with \"invalid +function: nil\". The fallback must be installed on both send variables and +must signal a `user-error' that names msmtp." + (test-mail-config--with-executables nil + (let (send-mail-function message-send-mail-function) + (cj/mail-configure-smtpmail) + (should (eq send-mail-function #'cj/mail--send-mail-unavailable)) + (should (eq message-send-mail-function #'cj/mail--send-mail-unavailable)) + (should-error (cj/mail--send-mail-unavailable) :type 'user-error) + (condition-case err + (cj/mail--send-mail-unavailable) + (user-error + (should (string-match-p "msmtp" (cadr err)))))))) + (ert-deftest test-mail-config-transport-mbsync-present-builds-command () "When mbsync exists, build the mu4e sync command." (test-mail-config--with-executables '(("mbsync" . "/usr/bin/mbsync")) diff --git a/tests/test-media-utils--argv.el b/tests/test-media-utils--argv.el new file mode 100644 index 00000000..81317b60 --- /dev/null +++ b/tests/test-media-utils--argv.el @@ -0,0 +1,72 @@ +;;; test-media-utils--argv.el --- Tests for media-utils argv builders -*- lexical-binding: t; -*- + +;;; Commentary: +;; Unit tests for the pure helpers behind cj/media-play-it's shell-free +;; launch: cj/media--yt-dlp-argv (stream-URL resolution command), +;; cj/media--stream-urls (yt-dlp -g output parsing), and +;; cj/media--play-argv (player launch argv). Argv lists are the +;; hardening: URLs and args never meet a shell. +;; +;; Test organization: +;; - Normal Cases: formats present/absent, args split, multi-line output +;; - Boundary Cases: metacharacter URLs verbatim, empty output, nil args +;; - Error Cases: none (builders are total; error paths live in the caller) +;; +;;; Code: + +(require 'ert) +(require 'media-utils) + +;;; cj/media--yt-dlp-argv + +(ert-deftest test-media-utils--yt-dlp-argv-normal-with-formats () + "Normal: formats join with / behind -f, URL last." + (should (equal (cj/media--yt-dlp-argv "https://example.com/v" '("22" "18" "best")) + '("yt-dlp" "-f" "22/18/best" "-g" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dlp-argv-normal-without-formats () + "Normal: nil formats drops the -f pair." + (should (equal (cj/media--yt-dlp-argv "https://example.com/v" nil) + '("yt-dlp" "-g" "https://example.com/v")))) + +(ert-deftest test-media-utils--yt-dlp-argv-boundary-metacharacter-url () + "Boundary: a URL with shell metacharacters stays one verbatim element." + (let ((url "https://example.com/v?a=1&b=$(x);c='d'")) + (should (equal (car (last (cj/media--yt-dlp-argv url nil))) url)))) + +;;; cj/media--stream-urls + +(ert-deftest test-media-utils--stream-urls-normal-two-lines () + "Normal: each non-empty output line is one stream URL." + (should (equal (cj/media--stream-urls "https://a/video\nhttps://a/audio\n") + '("https://a/video" "https://a/audio")))) + +(ert-deftest test-media-utils--stream-urls-boundary-blank-and-crlf () + "Boundary: blank lines and CR line endings are stripped." + (should (equal (cj/media--stream-urls "https://a/v\r\n\n \nhttps://a/u\r\n") + '("https://a/v" "https://a/u")))) + +(ert-deftest test-media-utils--stream-urls-boundary-empty-output () + "Boundary: empty output yields nil." + (should-not (cj/media--stream-urls ""))) + +;;; cj/media--play-argv + +(ert-deftest test-media-utils--play-argv-normal-args-split () + "Normal: the player's raw args string splits into argv words." + (should (equal (cj/media--play-argv "vlc" "--no-video --intf dummy" + '("https://a/v")) + '("vlc" "--no-video" "--intf" "dummy" "https://a/v")))) + +(ert-deftest test-media-utils--play-argv-boundary-nil-args () + "Boundary: nil args yields program + URLs only." + (should (equal (cj/media--play-argv "mpv" nil '("https://a/v")) + '("mpv" "https://a/v")))) + +(ert-deftest test-media-utils--play-argv-boundary-multiple-urls () + "Boundary: every resolved stream URL is appended in order." + (should (equal (cj/media--play-argv "mpv" nil '("https://a/v" "https://a/u")) + '("mpv" "https://a/v" "https://a/u")))) + +(provide 'test-media-utils--argv) +;;; test-media-utils--argv.el ends here diff --git a/tests/test-media-utils--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-mu4e-attachments.el b/tests/test-mu4e-attachments.el index 0a780977..986c2746 100644 --- a/tests/test-mu4e-attachments.el +++ b/tests/test-mu4e-attachments.el @@ -75,6 +75,56 @@ so this fails the same way whether or not mu4e's MIME support is loadable." (should-error (cj/mu4e--save-attachment-part part "/downloads") :type 'user-error))) +(ert-deftest test-mu4e-attachments-save-part-errors-on-stale-handle () + "Error: a handle whose MIME buffer was killed fails with a clear error. +The selection buffer captures handles when it opens; a real MIME handle's +car is the buffer holding the part's bytes, and viewing another message +kills it. Saving through it must signal a `user-error' naming the file, +not die in `mm-save-part-to-file' (or save another message's bytes)." + (let* ((dead (generate-new-buffer "stale-mime-part")) + (part (test-mu4e-attachments--part "invoice.pdf" 3 (list dead)))) + (kill-buffer dead) + (should-error (cj/mu4e--save-attachment-part part "/downloads") + :type 'user-error) + (condition-case err + (cj/mu4e--save-attachment-part part "/downloads") + (user-error (should (string-match-p "invoice\\.pdf" (cadr err))))))) + +(ert-deftest test-mu4e-attachments-save-part-live-buffer-handle-saves () + "Normal: a handle whose MIME buffer is alive saves normally." + (let* ((live (generate-new-buffer "live-mime-part")) + (part (test-mu4e-attachments--part "invoice.pdf" 3 (list live))) + (mu4e-uniquify-save-file-name-function #'identity) + saved) + (unwind-protect + (cl-letf (((symbol-function 'mu4e-join-paths) + (lambda (&rest pieces) (mapconcat #'identity pieces "/"))) + ((symbol-function 'mm-save-part-to-file) + (lambda (_handle path) (setq saved path)))) + (should (equal (cj/mu4e--save-attachment-part part "/downloads") + "/downloads/invoice.pdf")) + (should (equal saved "/downloads/invoice.pdf"))) + (kill-buffer live)))) + +(ert-deftest test-mu4e-attachments-save-parts-mid-batch-failure-propagates () + "Error: a mid-batch save failure propagates; earlier parts stay saved. +Characterizes the batch path: no silent skip of the failing part, and the +files already written are not rolled back." + (let ((parts (list (test-mu4e-attachments--part "a.pdf" 1) + (test-mu4e-attachments--part "b.pdf" 2) + (test-mu4e-attachments--part "c.pdf" 3))) + (saved '())) + (cl-letf (((symbol-function 'cj/mu4e--save-attachment-part) + (lambda (part _dir) + (let ((name (plist-get part :filename))) + (when (equal name "b.pdf") + (user-error "Stale handle: %s" name)) + (push name saved) + name)))) + (should-error (cj/mu4e--save-attachment-parts parts "/downloads") + :type 'user-error)) + (should (equal (nreverse saved) '("a.pdf"))))) + (ert-deftest test-mu4e-attachments-save-all-prompts-once () "Normal: the save-all command prompts for a directory once and saves all parts." (let ((parts (list (test-mu4e-attachments--part "a.pdf" 1) diff --git a/tests/test-music-config--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--append-track-to-m3u-file.el b/tests/test-music-config--append-track-to-m3u-file.el index be0cbd8e..cc40438c 100644 --- a/tests/test-music-config--append-track-to-m3u-file.el +++ b/tests/test-music-config--append-track-to-m3u-file.el @@ -39,7 +39,8 @@ "Append to brand new empty M3U file." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (track-path (expand-file-name "artist/song.mp3" cj/music-root)) (expected-relative "artist/song.mp3")) (cj/music--append-track-to-m3u-file track-path m3u-file) @@ -53,6 +54,7 @@ (test-music-config--append-track-to-m3u-file-setup) (unwind-protect (let* ((existing-content "first.mp3\n") + (cj/music-root (cj/create-test-base-dir)) (m3u-file (cj/create-temp-test-file-with-content existing-content "test-playlist-")) (track-path (expand-file-name "second.mp3" cj/music-root)) (expected-relative "second.mp3")) @@ -68,6 +70,7 @@ (test-music-config--append-track-to-m3u-file-setup) (unwind-protect (let* ((existing-content "first.mp3") + (cj/music-root (cj/create-test-base-dir)) (m3u-file (cj/create-temp-test-file-with-content existing-content "test-playlist-")) (track-path (expand-file-name "second.mp3" cj/music-root)) (expected-relative "second.mp3")) @@ -82,7 +85,8 @@ "Multiple appends to same file all succeed (allows duplicates)." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (track1 (expand-file-name "track1.mp3" cj/music-root)) (track2 (expand-file-name "track2.mp3" cj/music-root)) (track1-duplicate (expand-file-name "track1.mp3" cj/music-root)) @@ -98,13 +102,157 @@ (concat rel1 "\n" rel2 "\n" rel1 "\n")))))) (test-music-config--append-track-to-m3u-file-teardown))) +;;; Normal Cases: round-trip with the reader + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-round-trips-through-the-reader () + "Normal: the same-directory case round-trips through the reader. +A positive control only. With the playlist and the music root in one +directory both candidate bases produce the same string, so this passes +against the old writer too — the discriminating cases are the two tests +below, which put the bases at different depths." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (cj/music-root base) + (m3u-file (cj/create-temp-test-file "test-playlist-")) + (track-path (expand-file-name "artist/song.mp3" base))) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-round-trips-outside-the-music-root () + "Normal/regression: a playlist living outside `cj/music-root' round-trips. +This is the case the old writer got wrong. It based every relative path on +`cj/music-root' wherever the playlist sat, while the reader resolved against +the playlist's directory. Inside the music root the two coincide, which is +why the defect stayed invisible until a playlist moved out of it." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + ;; The layout mirrors the real one: playlists/ and audio/ are siblings + ;; under mpd/, and the music root is a separate tree at a different depth. + ;; The depth difference is load-bearing -- put the music root alongside + ;; playlists/ instead and both bases yield the same relative path, so the + ;; test passes against the broken writer and proves nothing. + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (audio (expand-file-name "mpd/audio/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "ambience.m3u" playlists)) + (track-path (expand-file-name "rain-loop.mp3" audio))) + (make-directory playlists t) + (make-directory audio t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-under-playlist-dir-is-relative () + "Normal: a track under the playlist's directory is written relative to it. +The music root sits at a different depth on purpose. Put it alongside the +playlist directory instead and both candidate bases produce the same string, +so the assertion would hold against a writer using either one." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "album.m3u" playlists)) + (track-path (expand-file-name "sub/song.mp3" playlists))) + (make-directory (expand-file-name "sub/" playlists) t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) "sub/song.mp3\n"))) + (should (equal (cj/music--m3u-file-tracks m3u-file) (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-sibling-dir-is-absolute () + "Normal: a track outside the playlist's directory is written absolute. +A sibling would otherwise come out as \"../audio/x.mp3\". Absolute is the +convention for cross-tree references here, and it survives the playlist being +moved again later, which a ../ chain does not." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (audio (expand-file-name "mpd/audio/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "ambience.m3u" playlists)) + (track-path (expand-file-name "rain-loop.mp3" audio))) + (make-directory playlists t) + (make-directory audio t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) (concat track-path "\n")))) + (should (equal (cj/music--m3u-file-tracks m3u-file) (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-deep-parent-chain-goes-absolute () + "Normal: a track several levels away is written absolute, not as a ../ chain. +This is the case the absolute fallback exists for. A four-level chain is +unreadable and breaks the moment the playlist moves, so distance from the +playlist is exactly when an absolute path earns its keep." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "a/b/c/playlists/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "deep.m3u" playlists)) + (track-path (expand-file-name "faraway/song.mp3" base))) + (make-directory playlists t) + (make-directory (expand-file-name "faraway/" base) t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + ;; Four hops up (playlists -> c -> b -> a -> base) would be the + ;; relative form; the writer declines it and emits the absolute path. + (should (string= (buffer-string) (concat track-path "\n")))) + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + ;;; Boundary Cases +(ert-deftest test-music-config--append-track-to-m3u-file-boundary-dotdot-named-dir-stays-relative () + "Boundary: a directory whose name merely begins with two dots stays relative. +This is the input the relative-vs-absolute test actually turns on. The check +looks for a leading \"../\", so a real subdirectory named \"..hidden\" is under +the playlist and must not be mistaken for an escape. Loosening the check to +\"..\" would break exactly this case and nothing else in the suite would catch +it." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "p.m3u" playlists)) + (track-path (expand-file-name "..hidden/song.mp3" playlists))) + (make-directory (expand-file-name "..hidden/" playlists) t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) "..hidden/song.mp3\n"))) + (should (equal (cj/music--m3u-file-tracks m3u-file) (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + (ert-deftest test-music-config--append-track-to-m3u-file-boundary-very-long-path-appends-successfully () "Append very long track path without truncation." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) ;; Create a relative path that's ~450 chars long (relative-path (concat (make-string 440 ?a) "/song.mp3")) (track-path (expand-file-name relative-path cj/music-root))) @@ -119,7 +267,8 @@ "Append path with unicode characters preserves UTF-8 encoding." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (relative-path "中文/artist-名前/song🎵.mp3") (track-path (expand-file-name relative-path cj/music-root))) (cj/music--append-track-to-m3u-file track-path m3u-file) @@ -132,7 +281,8 @@ "Append path with spaces and special characters." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (relative-path "Artist Name/Album (2024)/01 - Song's Title [Remix].mp3") (track-path (expand-file-name relative-path cj/music-root))) (cj/music--append-track-to-m3u-file track-path m3u-file) @@ -146,6 +296,7 @@ (test-music-config--append-track-to-m3u-file-setup) (unwind-protect (let* ((existing-content "#EXTM3U\n#EXTINF:-1,Radio Station\nhttp://stream.url/radio\n") + (cj/music-root (cj/create-test-base-dir)) (m3u-file (cj/create-temp-test-file-with-content existing-content "test-playlist-")) (relative-path "local-track.mp3") (track-path (expand-file-name relative-path cj/music-root))) @@ -156,6 +307,73 @@ (concat existing-content relative-path "\n"))))) (test-music-config--append-track-to-m3u-file-teardown))) +;;; Boundary Cases: symlinked playlists + +(defun test-music-config--append--make-symlinked-playlist (base content link-depth) + "Create a playlist whose deployed path is a symlink, and return that path. +CONTENT is written to the real file. LINK-DEPTH controls how long the link +string is, which is the whole point: `file-attributes' does not follow +symlinks, so a writer sizing the file that way reads the length of the link +rather than the content." + (let* ((deployed (expand-file-name "deployed/" base)) + (deep (expand-file-name (mapconcat #'identity + (make-list link-depth "longdirname") + "/") + base)) + (real (expand-file-name "p.m3u" deep)) + (link (expand-file-name "p.m3u" deployed))) + (make-directory deep t) + (make-directory deployed t) + (with-temp-buffer (insert content) (write-file real)) + (make-symbolic-link (file-relative-name real deployed) link t) + link)) + +(ert-deftest test-music-config--append-track-to-m3u-file-boundary-symlink-longer-than-content () + "Boundary: appending to a symlinked playlist whose link string is longer than +its content must not signal. Sizing the file with `file-attributes' returns +the link's length, so the read range falls outside the file, nothing is +inserted, and `char-after' hands nil to a numeric comparison. Measured on the +real deployed set: 31 of 100 symlinked playlists are in this state." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (m3u-file (test-music-config--append--make-symlinked-playlist + base "https://example.com/s.mp3\n" 8)) + (track-path (expand-file-name "song.mp3" (file-name-directory m3u-file)))) + (should (> (file-attribute-size (file-attributes m3u-file)) + (file-attribute-size (file-attributes (file-truename m3u-file))))) + (cj/music--append-track-to-m3u-file track-path m3u-file) + ;; The seeded line is a stream URL, which the reader passes through, so + ;; both entries come back. + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list "https://example.com/s.mp3" track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-boundary-symlink-no-spurious-blank-line () + "Boundary: a symlinked playlist already ending in a newline gains no blank line. +The trailing-newline probe reads a byte chosen from the wrong size, so it +misreads a terminated file as unterminated and prepends a newline. All 100 +symlinked playlists in the deployed set read the wrong byte this way." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + ;; Content deliberately longer than the link string, so the misread byte + ;; still lands inside the file. That separates this from the sibling test + ;; above: here the probe reads a valid but wrong byte and silently + ;; misjudges, rather than reading past the end and signalling. + (let* ((base (cj/create-test-base-dir)) + (content (mapconcat (lambda (i) (format "track-%03d-with-a-longish-name.mp3" i)) + (number-sequence 1 12) "\n")) + (m3u-file (test-music-config--append--make-symlinked-playlist + base (concat content "\n") 2)) + (track-path (expand-file-name "second.mp3" (file-name-directory m3u-file)))) + (should (< (file-attribute-size (file-attributes m3u-file)) + (file-attribute-size (file-attributes (file-truename m3u-file))))) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) (concat content "\nsecond.mp3\n"))))) + (test-music-config--append-track-to-m3u-file-teardown))) + ;;; Error Cases (ert-deftest test-music-config--append-track-to-m3u-file-error-nonexistent-file-signals-error () @@ -172,6 +390,9 @@ "Signal error when M3U file is read-only." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect + ;; No `cj/music-root' rebinding here: the writable-p guard signals before + ;; any path computation runs, so binding it would imply a dependency the + ;; read-only path does not have. (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) (track-path "/home/user/music/song.mp3")) ;; Make file read-only diff --git a/tests/test-music-config--art-cache-key.el b/tests/test-music-config--art-cache-key.el new file mode 100644 index 00000000..bc869808 --- /dev/null +++ b/tests/test-music-config--art-cache-key.el @@ -0,0 +1,69 @@ +;;; test-music-config--art-cache-key.el --- Tests for cover-art cache key -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music-art--cache-key': the stable cache-file basename for +;; a track. A url with a known #RADIOBROWSERUUID keys on the uuid (so the same +;; station shares one cached logo); any other url keys on a hash of its address; +;; a file keys on a hash of its path. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(ert-deftest test-music-config--art-cache-key-normal-uuid () + "Normal: a url with a UUID in the entries keys on the UUID." + (let ((track (emms-track 'url "https://ck.somafm.com/gs")) + (entries '(("https://ck.somafm.com/gs" :name "GS" :uuid "uuid-42" :favicon nil)))) + (should (string= (cj/music-art--cache-key track entries) "uuid-42")))) + +(ert-deftest test-music-config--art-cache-key-boundary-url-no-uuid () + "Boundary: a url with no UUID keys on a stable url- hash, not the raw URL." + (let* ((url "https://ck2.example.net/live") + (track (emms-track 'url url)) + (key (cj/music-art--cache-key track nil))) + (should (string-prefix-p "url-" key)) + (should (string= key (concat "url-" (sha1 url)))))) + +(ert-deftest test-music-config--art-cache-key-normal-file () + "Normal: a file keys on a file- hash of its path." + (let* ((path "/music/Kind of Blue/01.flac") + (track (emms-track 'file path))) + (should (string= (cj/music-art--cache-key track nil) + (concat "file-" (sha1 path)))))) + +(ert-deftest test-music-config--art-cache-key-boundary-empty-uuid-falls-to-hash () + "Boundary: an empty-string UUID is treated as absent, so the url hashes." + (let* ((url "https://ck3.example.net/x") + (track (emms-track 'url url)) + (entries (list (list url :name "X" :uuid "" :favicon nil)))) + (should (string= (cj/music-art--cache-key track entries) + (concat "url-" (sha1 url)))))) + +(ert-deftest test-music-config--art-cache-key-normal-track-property () + "Normal: a queued lookup station carries its uuid as a track property and +needs no entries at all." + (let ((track (emms-track 'url "https://ck4.example.net/live"))) + (emms-track-set track 'radio-uuid "prop-uuid") + (should (string= (cj/music-art--cache-key track nil) "prop-uuid")))) + +(ert-deftest test-music-config--art-cache-key-normal-property-beats-entries () + "Normal: the track property wins over a conflicting entries uuid." + (let* ((url "https://ck5.example.net/live") + (track (emms-track 'url url)) + (entries (list (list url :name "X" :uuid "entries-uuid" :favicon nil)))) + (emms-track-set track 'radio-uuid "prop-uuid") + (should (string= (cj/music-art--cache-key track entries) "prop-uuid")))) + +(provide 'test-music-config--art-cache-key) +;;; test-music-config--art-cache-key.el ends here diff --git a/tests/test-music-config--art-favicon-url.el b/tests/test-music-config--art-favicon-url.el new file mode 100644 index 00000000..9e7b92f8 --- /dev/null +++ b/tests/test-music-config--art-favicon-url.el @@ -0,0 +1,69 @@ +;;; test-music-config--art-favicon-url.el --- Tests for stream favicon URL -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music-art--favicon-url': the direct favicon image URL for +;; a url track, taken from the #RADIOBROWSERFAVICON captured at station creation. +;; A station with only a UUID resolves its favicon via a separate byuuid lookup +;; (done in the impure orchestrator), so this pure helper returns nil there. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(ert-deftest test-music-config--art-favicon-url-normal-captured () + "Normal: a captured #RADIOBROWSERFAVICON is returned directly." + (let ((track (emms-track 'url "https://fav.somafm.com/gs")) + (entries '(("https://fav.somafm.com/gs" + :name "GS" :uuid "u1" :favicon "https://cdn.example/gs.png")))) + (should (string= (cj/music-art--favicon-url track entries) + "https://cdn.example/gs.png")))) + +(ert-deftest test-music-config--art-favicon-url-boundary-uuid-only () + "Boundary: a station with a UUID but no captured favicon returns nil +\(the byuuid lookup is the orchestrator's job)." + (let ((track (emms-track 'url "https://fav2.example.net/live")) + (entries '(("https://fav2.example.net/live" + :name "X" :uuid "u2" :favicon nil)))) + (should (null (cj/music-art--favicon-url track entries))))) + +(ert-deftest test-music-config--art-favicon-url-boundary-empty-favicon () + "Boundary: an empty-string favicon is treated as absent." + (let ((track (emms-track 'url "https://fav3.example.net/live")) + (entries '(("https://fav3.example.net/live" :name "X" :uuid "u3" :favicon "")))) + (should (null (cj/music-art--favicon-url track entries))))) + +(ert-deftest test-music-config--art-favicon-url-error-file-track () + "Error: a file track has no stream favicon URL." + (let ((track (emms-track 'file "/music/x.flac"))) + (should (null (cj/music-art--favicon-url track nil))))) + +(ert-deftest test-music-config--art-favicon-url-normal-track-property () + "Normal: a queued lookup station carries its favicon as a track property." + (let ((track (emms-track 'url "https://fp.example.net/live"))) + (emms-track-set track 'radio-favicon "https://fp.example.net/icon.png") + (should (string= (cj/music-art--favicon-url track nil) + "https://fp.example.net/icon.png")))) + +(ert-deftest test-music-config--art-favicon-url-normal-property-beats-entries () + "Normal: the track property wins over a conflicting entries favicon." + (let* ((url "https://fp2.example.net/live") + (track (emms-track 'url url)) + (entries (list (list url :name "X" :uuid nil + :favicon "https://entries.example/e.png")))) + (emms-track-set track 'radio-favicon "https://prop.example/p.png") + (should (string= (cj/music-art--favicon-url track entries) + "https://prop.example/p.png")))) + +(provide 'test-music-config--art-favicon-url) +;;; test-music-config--art-favicon-url.el ends here diff --git a/tests/test-music-config--art-valid-image.el b/tests/test-music-config--art-valid-image.el new file mode 100644 index 00000000..c8de0eda --- /dev/null +++ b/tests/test-music-config--art-valid-image.el @@ -0,0 +1,51 @@ +;;; test-music-config--art-valid-image.el --- Tests for fetched-image validation -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music-art--valid-image-p': recognize whether fetched bytes +;; are actually a displayable image, so an empty body, an HTML error page served +;; 200, or a text response is rejected before it lands in the cache. Detection +;; is by image header (`image-type-from-data'), which works headless. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(defconst test-art--png-1x1 + (base64-decode-string + (concat "iVBORw0KGgoAAAANSUhEUgAAAAEAAAABCAQAAAC1HAwCAAAAC0lEQVR42mNk" + "YPhfDwAChwGA60e6kgAAAABJRU5ErkJggg==")) + "A minimal valid 1x1 PNG, as raw bytes.") + +(ert-deftest test-music-config--art-valid-image-normal-png () + "Normal: real PNG bytes are recognized as a valid image." + (should (cj/music-art--valid-image-p test-art--png-1x1))) + +(ert-deftest test-music-config--art-valid-image-error-html () + "Error: an HTML error page served 200 is not a valid image." + (should-not (cj/music-art--valid-image-p "<html><body>502 Bad Gateway</body></html>"))) + +(ert-deftest test-music-config--art-valid-image-error-text () + "Error: arbitrary text is not a valid image." + (should-not (cj/music-art--valid-image-p "this is not an image"))) + +(ert-deftest test-music-config--art-valid-image-boundary-empty () + "Boundary: an empty body is not a valid image." + (should-not (cj/music-art--valid-image-p ""))) + +(ert-deftest test-music-config--art-valid-image-boundary-nil () + "Boundary: nil is not a valid image." + (should-not (cj/music-art--valid-image-p nil))) + +(provide 'test-music-config--art-valid-image) +;;; test-music-config--art-valid-image.el ends here diff --git a/tests/test-music-config--bar-fill.el b/tests/test-music-config--bar-fill.el new file mode 100644 index 00000000..f6d8dac8 --- /dev/null +++ b/tests/test-music-config--bar-fill.el @@ -0,0 +1,63 @@ +;;; test-music-config--bar-fill.el --- Tests for progress-bar fill math -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--bar-fill': the pure computation of how many cells +;; of a WIDTH-cell progress bar are filled given ELAPSED and TOTAL seconds. +;; A stream (no duration) is indeterminate; the live elapsed source (mpv) is +;; wired in a later phase, so this helper only does the clamp-and-round math. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +;;; Normal + +(ert-deftest test-music-config--bar-fill-normal-half () + "Normal: halfway through fills half the cells." + (should (= (cj/music--bar-fill 30 60 20) 10))) + +(ert-deftest test-music-config--bar-fill-normal-quarter () + "Normal: a quarter elapsed rounds to a quarter of the cells." + (should (= (cj/music--bar-fill 15 60 20) 5))) + +;;; Boundary + +(ert-deftest test-music-config--bar-fill-boundary-zero-elapsed () + "Boundary: nothing elapsed fills no cells." + (should (= (cj/music--bar-fill 0 60 20) 0))) + +(ert-deftest test-music-config--bar-fill-boundary-full () + "Boundary: elapsed equal to total fills every cell." + (should (= (cj/music--bar-fill 60 60 20) 20))) + +(ert-deftest test-music-config--bar-fill-boundary-over-clamps () + "Boundary: elapsed past total clamps to full, never overflows." + (should (= (cj/music--bar-fill 90 60 20) 20))) + +(ert-deftest test-music-config--bar-fill-boundary-nil-elapsed () + "Boundary: an unknown elapsed (nil) fills no cells." + (should (= (cj/music--bar-fill nil 60 20) 0))) + +;;; Error / indeterminate + +(ert-deftest test-music-config--bar-fill-indeterminate-nil-total () + "Error: a stream (nil total) is indeterminate, not a cell count." + (should (eq (cj/music--bar-fill 30 nil 20) 'indeterminate))) + +(ert-deftest test-music-config--bar-fill-indeterminate-zero-total () + "Error: a zero total is indeterminate rather than a divide-by-zero." + (should (eq (cj/music--bar-fill 30 0 20) 'indeterminate))) + +(provide 'test-music-config--bar-fill) +;;; test-music-config--bar-fill.el ends here diff --git a/tests/test-music-config--bar-string.el b/tests/test-music-config--bar-string.el new file mode 100644 index 00000000..bb6ac96f --- /dev/null +++ b/tests/test-music-config--bar-string.el @@ -0,0 +1,50 @@ +;;; test-music-config--bar-string.el --- Tests for the block progress bar -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--bar-string': render a WIDTH-cell block bar from a +;; filled-cell count (from `cj/music--bar-fill'), or an "on air" marker when the +;; fill is `indeterminate' (a live stream with no duration). Face-carrying +;; text; the tests assert the rendered length and content, not the faces. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(ert-deftest test-music-config--bar-string-normal-half () + "Normal: 10 of 20 cells filled renders a 20-cell bar." + (let ((s (substring-no-properties (cj/music--bar-string 10 20)))) + (should (= (length s) 20)) + (should (= (cl-count ?█ s) 10)) + (should (= (cl-count ?░ s) 10)))) + +(ert-deftest test-music-config--bar-string-boundary-empty () + "Boundary: zero fill is all empty cells." + (let ((s (substring-no-properties (cj/music--bar-string 0 20)))) + (should (= (cl-count ?█ s) 0)) + (should (= (cl-count ?░ s) 20)))) + +(ert-deftest test-music-config--bar-string-boundary-full () + "Boundary: full fill is all filled cells." + (let ((s (substring-no-properties (cj/music--bar-string 20 20)))) + (should (= (cl-count ?█ s) 20)) + (should (= (cl-count ?░ s) 0)))) + +(ert-deftest test-music-config--bar-string-indeterminate-on-air () + "Error/indeterminate: a stream renders an on-air marker, not a bar." + (let ((s (substring-no-properties (cj/music--bar-string 'indeterminate 20)))) + (should (string-match-p "on air" s)) + (should (= (cl-count ?█ s) 0)))) + +(provide 'test-music-config--bar-string) +;;; test-music-config--bar-string.el ends here diff --git a/tests/test-music-config--completion-table.el b/tests/test-music-config--completion-table.el index 5e33e655..6b3da442 100644 --- a/tests/test-music-config--completion-table.el +++ b/tests/test-music-config--completion-table.el @@ -19,6 +19,10 @@ (defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") +;; Declare special here too (the module's bare defvar is file-local) so the +;; registration test's `let' binds dynamically. +(defvar marginalia-annotator-registry) + ;; Load production code (require 'music-config) @@ -131,5 +135,15 @@ ;; Should not crash, returns empty (should (null result)))) +;;; Marginalia registration + +(ert-deftest test-music-config--completion-table-registers-with-marginalia () + "Normal: building the table registers cj-music-file so marginalia +right-aligns the size/date annotations." + (let ((marginalia-annotator-registry '())) + (cj/music--completion-table '("a.mp3")) + (should (equal (assq 'cj-music-file marginalia-annotator-registry) + '(cj-music-file builtin none))))) + (provide 'test-music-config--completion-table) ;;; test-music-config--completion-table.el ends here diff --git a/tests/test-music-config--delete-playlist-file.el b/tests/test-music-config--delete-playlist-file.el new file mode 100644 index 00000000..ace51a4d --- /dev/null +++ b/tests/test-music-config--delete-playlist-file.el @@ -0,0 +1,135 @@ +;;; test-music-config--delete-playlist-file.el --- Tests for playlist file deletion -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for cj/music--delete-playlist-file function. +;; Tests the internal helper that removes a playlist's .m3u file, +;; clears the playlist buffer's file association when it pointed at +;; the deleted file, and refreshes the radio metadata cache. +;; +;; Test organization: +;; - Normal Cases: Existing file is deleted +;; - Boundary Cases: Association cleared only when it matches; cache refresh +;; - Error Cases: Nil path, nonexistent path +;; +;;; Code: + +(require 'ert) +(require 'testutil-general) + +;; Stub missing dependencies before loading music-config +(defvar-keymap cj/custom-keymap + :doc "Stub keymap for testing") + +;; Add EMMS elpa directory to load path for batch testing +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir + (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'emms-playlist-mode) +(require 'music-config) + +;;; Test helpers + +(defun test-delete-playlist--setup () + "Create test base dir and ensure playlist buffer exists." + (cj/create-test-base-dir) + (let ((buf (get-buffer-create cj/music-playlist-buffer-name))) + (with-current-buffer buf + (emms-playlist-mode) + (setq emms-playlist-buffer-p t)) + (setq emms-playlist-buffer buf) + buf)) + +(defun test-delete-playlist--teardown () + "Clean up test playlist buffer and temp files." + (when-let ((buf (get-buffer cj/music-playlist-buffer-name))) + (with-current-buffer buf + (setq cj/music-playlist-file nil)) + (kill-buffer buf)) + (cj/delete-test-base-dir)) + +;;; Normal Cases + +(ert-deftest test-music-config--delete-playlist-file-normal-removes-file () + "Normal: an existing playlist file is deleted from disk." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n/tmp/song.mp3\n" "playlist.m3u"))) + (cj/music--delete-playlist-file file) + (should-not (file-exists-p file))) + (test-delete-playlist--teardown))) + +;;; Boundary Cases + +(ert-deftest test-music-config--delete-playlist-file-boundary-clears-matching-association () + "Boundary: deleting the associated playlist file clears the association." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n" "playlist.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file file)) + (cj/music--delete-playlist-file file) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should-not cj/music-playlist-file))) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-boundary-keeps-other-association () + "Boundary: deleting a different file leaves the association untouched." + (test-delete-playlist--setup) + (unwind-protect + (let ((doomed (cj/create-temp-test-file-with-content + "#EXTM3U\n" "doomed.m3u")) + (kept (cj/create-temp-test-file-with-content + "#EXTM3U\n" "kept.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file kept)) + (cj/music--delete-playlist-file doomed) + (should (file-exists-p kept)) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should (equal cj/music-playlist-file kept)))) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-boundary-refreshes-radio-cache () + "Boundary: deletion clears the cached radio metadata." + (test-delete-playlist--setup) + (unwind-protect + (let ((file (cj/create-temp-test-file-with-content + "#EXTM3U\n" "playlist.m3u"))) + (setq cj/music--radio-metadata-cache '(("stale" . "entry"))) + (cj/music--delete-playlist-file file) + (should-not cj/music--radio-metadata-cache)) + (test-delete-playlist--teardown))) + +;;; Error Cases + +(ert-deftest test-music-config--delete-playlist-file-error-nil-path () + "Error: nil path signals user-error." + (test-delete-playlist--setup) + (unwind-protect + (should-error (cj/music--delete-playlist-file nil) :type 'user-error) + (test-delete-playlist--teardown))) + +(ert-deftest test-music-config--delete-playlist-file-error-nonexistent-path () + "Error: a path that does not exist signals user-error and touches nothing." + (test-delete-playlist--setup) + (unwind-protect + (let ((kept (cj/create-temp-test-file-with-content + "#EXTM3U\n" "kept.m3u"))) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (setq cj/music-playlist-file kept)) + (should-error + (cj/music--delete-playlist-file + (expand-file-name "no-such.m3u" cj/test-base-dir)) + :type 'user-error) + (with-current-buffer (get-buffer cj/music-playlist-buffer-name) + (should (equal cj/music-playlist-file kept)))) + (test-delete-playlist--teardown))) + +(provide 'test-music-config--delete-playlist-file) +;;; test-music-config--delete-playlist-file.el ends here diff --git a/tests/test-music-config--display-name.el b/tests/test-music-config--display-name.el new file mode 100644 index 00000000..c1065f3a --- /dev/null +++ b/tests/test-music-config--display-name.el @@ -0,0 +1,139 @@ +;;; test-music-config--display-name.el --- Tests for track display-name -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--display-name' and `cj/music--format-meta'. +;; +;; display-name is the pure, name-only resolver shared by the header's Current +;; line and the playlist row renderer: for a tagged track it returns +;; "Artist - Title" (no duration -- duration is right-aligned meta, not name); +;; for an untagged file the clean filename; for a url track the #EXTINF label +;; from a passed name-map, else a tidied host; unknown types fall back to +;; emms-track-simple-description. +;; +;; format-meta returns the right-aligned meta string for a row: a file's +;; duration as "[M:SS]", empty otherwise. +;; +;; Track independence: `emms-track' returns a track cached by (type . name) +;; once EMMS is loaded, so two tests sharing a name would share a mutated +;; object. Every test below uses a UNIQUE track name to stay independent. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'emms-playlist-mode) +(require 'music-config) + +;;; Helpers + +(defun test-display-name--file (path &optional title artist duration) + "Create a file TRACK with PATH and optional TITLE ARTIST DURATION." + (let ((track (emms-track 'file path))) + (when title (emms-track-set track 'info-title title)) + (when artist (emms-track-set track 'info-artist artist)) + (when duration (emms-track-set track 'info-playing-time duration)) + track)) + +(defun test-display-name--url (url &optional title artist) + "Create a url TRACK with URL and optional TITLE ARTIST." + (let ((track (emms-track 'url url))) + (when title (emms-track-set track 'info-title title)) + (when artist (emms-track-set track 'info-artist artist)) + track)) + +;;; Normal -- tagged tracks (no duration in the name) + +(ert-deftest test-music-config--display-name-normal-artist-title () + "Normal: tagged track shows Artist - Title, no duration bracket." + (let ((track (test-display-name--file + "/dn/artist-title.flac" "So What" "Miles Davis" 562))) + (should (string= (cj/music--display-name track) "Miles Davis - So What")))) + +(ert-deftest test-music-config--display-name-normal-title-only () + "Normal: title without artist shows the title alone." + (let ((track (test-display-name--file "/dn/title-only.mp3" "Flamenco Sketches" nil 566))) + (should (string= (cj/music--display-name track) "Flamenco Sketches")))) + +;;; Normal -- untagged file + +(ert-deftest test-music-config--display-name-normal-file-no-tags () + "Normal: untagged file shows filename without path or extension." + (let ((track (test-display-name--file "/dn/Kind of Blue/02 - Freddie.flac"))) + (should (string= (cj/music--display-name track) "02 - Freddie")))) + +;;; Normal -- url resolves to #EXTINF label from the name-map + +(ert-deftest test-music-config--display-name-normal-url-label-from-map () + "Normal: a url track resolves to its #EXTINF label via the name-map." + (let ((track (test-display-name--url "https://ice6.somafm.com/groovesalad-256-mp3")) + (map '(("https://ice6.somafm.com/groovesalad-256-mp3" . "SomaFM Groove Salad")))) + (should (string= (cj/music--display-name track map) "SomaFM Groove Salad")))) + +;;; Normal -- url with tags formats like a tagged track + +(ert-deftest test-music-config--display-name-normal-url-with-tags () + "Normal: a url track carrying tags uses Artist - Title, not the URL." + (let ((track (test-display-name--url "https://tagged.example.com/stream" + "Jazz FM" "Radio Station"))) + (should (string= (cj/music--display-name track) "Radio Station - Jazz FM")))) + +;;; Boundary -- url with no label falls back to a tidied host + +(ert-deftest test-music-config--display-name-boundary-url-host-fallback () + "Boundary: a url with no label and no map falls back to the tidied host." + (let ((track (test-display-name--url "https://ice6.hostonly.somafm.com/gs"))) + (should (string= (cj/music--display-name track) "somafm.com")))) + +(ert-deftest test-music-config--display-name-boundary-url-not-in-map () + "Boundary: a url absent from a non-empty map still falls to the host." + (let ((track (test-display-name--url "https://stream.other.net/live")) + (map '(("https://ice6.somafm.com/x" . "Groove Salad")))) + (should (string= (cj/music--display-name track map) "other.net")))) + +(ert-deftest test-music-config--display-name-boundary-unicode-title () + "Boundary: unicode in the title is preserved." + (let ((track (test-display-name--file "/dn/unicode.mp3" "夜に駆ける" "YOASOBI" 258))) + (should (string= (cj/music--display-name track) "YOASOBI - 夜に駆ける")))) + +(ert-deftest test-music-config--display-name-boundary-file-multiple-dots () + "Boundary: only the final extension is stripped." + (let ((track (test-display-name--file "/dn/disc.1.track.03.flac"))) + (should (string= (cj/music--display-name track) "disc.1.track.03")))) + +;;; Error -- unknown type falls back without erroring + +(ert-deftest test-music-config--display-name-error-unknown-type () + "Error: an unknown track type falls back to a string, no error." + (let* ((track (emms-track 'streamlist "https://unknown.example.com/playlist.m3u")) + (result (cj/music--display-name track))) + (should (stringp result)) + (should (string-match-p "example\\.com" result)))) + +;;; format-meta + +(ert-deftest test-music-config--format-meta-normal-file-duration () + "Normal: a file with a duration yields the bracketed M:SS meta." + (let ((track (test-display-name--file "/dn/meta-dur.flac" "So What" "Miles" 562))) + (should (string= (cj/music--format-meta track) "[9:22]")))) + +(ert-deftest test-music-config--format-meta-boundary-no-duration () + "Boundary: a track with no duration yields an empty meta string." + (let ((track (test-display-name--file "/dn/meta-nodur.flac" "So What" "Miles"))) + (should (string= (cj/music--format-meta track) "")))) + +(ert-deftest test-music-config--format-meta-boundary-url-no-meta () + "Boundary: a url stream with no duration yields empty meta." + (let ((track (test-display-name--url "https://meta.example.com/stream"))) + (should (string= (cj/music--format-meta track) "")))) + +(provide 'test-music-config--display-name) +;;; test-music-config--display-name.el ends here diff --git a/tests/test-music-config--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-entries.el b/tests/test-music-config--m3u-entries.el new file mode 100644 index 00000000..1eaf1345 --- /dev/null +++ b/tests/test-music-config--m3u-entries.el @@ -0,0 +1,67 @@ +;;; test-music-config--m3u-entries.el --- Tests for #EXTINF/UUID/favicon parse -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--m3u-entries': parse .m3u text into an alist of +;; (stream-url . plist), each plist carrying :name (the #EXTINF label), :uuid +;; (#RADIOBROWSERUUID), and :favicon (#RADIOBROWSERFAVICON). This is the one +;; pure parser both the name resolution (Phase 1) and the cover-art layer read. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(ert-deftest test-music-config--m3u-entries-normal-name-only () + "Normal: an #EXTINF + url pair yields :name with nil :uuid and :favicon." + (let* ((text "#EXTM3U\n#EXTINF:1,SomaFM Groove Salad\nhttps://ice6.somafm.com/gs\n") + (e (cdr (assoc "https://ice6.somafm.com/gs" (cj/music--m3u-entries text))))) + (should (equal (plist-get e :name) "SomaFM Groove Salad")) + (should (null (plist-get e :uuid))) + (should (null (plist-get e :favicon))))) + +(ert-deftest test-music-config--m3u-entries-normal-uuid-and-favicon () + "Normal: UUID and favicon comment lines are captured onto the entry." + (let* ((text (concat "#EXTM3U\n#EXTINF:1,Jazz24\n" + "#RADIOBROWSERUUID:abc-123\n" + "#RADIOBROWSERFAVICON:https://cdn.example/jazz.png\n" + "https://jazz.example/live\n")) + (e (cdr (assoc "https://jazz.example/live" (cj/music--m3u-entries text))))) + (should (equal (plist-get e :name) "Jazz24")) + (should (equal (plist-get e :uuid) "abc-123")) + (should (equal (plist-get e :favicon) "https://cdn.example/jazz.png")))) + +(ert-deftest test-music-config--m3u-entries-normal-multiple-reset () + "Normal: fields reset between stations (station B has no UUID leak from A)." + (let* ((text (concat "#EXTINF:1,A\n#RADIOBROWSERUUID:aaa\nhttps://a.example/1\n" + "#EXTINF:1,B\nhttps://b.example/2\n")) + (entries (cj/music--m3u-entries text)) + (b (cdr (assoc "https://b.example/2" entries)))) + (should (equal (plist-get b :name) "B")) + (should (null (plist-get b :uuid))))) + +(ert-deftest test-music-config--m3u-entries-boundary-url-without-extinf () + "Boundary: a bare url with no #EXTINF is skipped." + (should (null (cj/music--m3u-entries "#EXTM3U\nhttps://plain.example/stream\n")))) + +(ert-deftest test-music-config--m3u-entries-boundary-empty () + "Boundary: empty text yields nil." + (should (null (cj/music--m3u-entries "")))) + +(ert-deftest test-music-config--m3u-entries-boundary-comma-in-name () + "Boundary: a comma inside the #EXTINF label is preserved." + (let* ((text "#EXTINF:1,Radio, the Good Kind\nhttps://x.example/s\n") + (e (cdr (assoc "https://x.example/s" (cj/music--m3u-entries text))))) + (should (equal (plist-get e :name) "Radio, the Good Kind")))) + +(provide 'test-music-config--m3u-entries) +;;; test-music-config--m3u-entries.el ends here diff --git a/tests/test-music-config--m3u-file-tracks.el b/tests/test-music-config--m3u-file-tracks.el index badc9817..e3cbd72e 100644 --- a/tests/test-music-config--m3u-file-tracks.el +++ b/tests/test-music-config--m3u-file-tracks.el @@ -189,5 +189,23 @@ "Parse nil input returns nil gracefully." (should (null (cj/music--m3u-file-tracks nil)))) +;;; Non-music filtering + +(ert-deftest test-music-config--m3u-file-tracks-filters-non-music-local-files () + "Normal: a local non-music path (a saved cover.jpg line) is dropped; +music files and stream URLs pass through." + (test-music-config--m3u-file-tracks-setup) + (unwind-protect + (let* ((content (concat "/home/user/music/track1.mp3\n" + "/home/user/music/album/cover.jpg\n" + "https://somafm.com/stream\n" + "/home/user/music/track2.flac\n")) + (m3u-file (cj/create-temp-test-file-with-content content "test.m3u")) + (tracks (cj/music--m3u-file-tracks m3u-file))) + (should (equal tracks '("/home/user/music/track1.mp3" + "https://somafm.com/stream" + "/home/user/music/track2.flac")))) + (test-music-config--m3u-file-tracks-teardown))) + (provide 'test-music-config--m3u-file-tracks) ;;; test-music-config--m3u-file-tracks.el ends here diff --git a/tests/test-music-config--m3u-labels.el b/tests/test-music-config--m3u-labels.el new file mode 100644 index 00000000..02f328cd --- /dev/null +++ b/tests/test-music-config--m3u-labels.el @@ -0,0 +1,62 @@ +;;; test-music-config--m3u-labels.el --- Tests for #EXTINF label extraction -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--m3u-labels': parse .m3u text into an alist of +;; (stream-url . #EXTINF-label) pairs. This is the pure core that lets a url +;; track resolve to its station name (the label written at creation) instead +;; of the raw stream URL. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(ert-deftest test-music-config--m3u-labels-normal-single () + "Normal: one #EXTINF + url pair yields one (url . label) cons." + (let ((text "#EXTM3U\n#EXTINF:1,SomaFM Groove Salad\nhttps://ice6.somafm.com/gs\n")) + (should (equal (cj/music--m3u-labels text) + '(("https://ice6.somafm.com/gs" . "SomaFM Groove Salad")))))) + +(ert-deftest test-music-config--m3u-labels-normal-uuid-line-between () + "Normal: a #RADIOBROWSERUUID line between #EXTINF and the url is skipped." + (let ((text (concat "#EXTM3U\n#EXTINF:1,Jazz24\n" + "#RADIOBROWSERUUID:abc-123\nhttps://jazz.example/live\n"))) + (should (equal (cj/music--m3u-labels text) + '(("https://jazz.example/live" . "Jazz24")))))) + +(ert-deftest test-music-config--m3u-labels-normal-multiple () + "Normal: multiple stations each yield their own pair." + (let ((text (concat "#EXTM3U\n" + "#EXTINF:1,Station A\nhttps://a.example/1\n" + "#EXTINF:-1,Station B\nhttps://b.example/2\n"))) + (should (equal (cj/music--m3u-labels text) + '(("https://a.example/1" . "Station A") + ("https://b.example/2" . "Station B")))))) + +(ert-deftest test-music-config--m3u-labels-boundary-url-without-extinf () + "Boundary: a bare url with no preceding #EXTINF produces no pair." + (let ((text "#EXTM3U\nhttps://plain.example/stream\n")) + (should (null (cj/music--m3u-labels text))))) + +(ert-deftest test-music-config--m3u-labels-boundary-empty () + "Boundary: empty text yields nil." + (should (null (cj/music--m3u-labels "")))) + +(ert-deftest test-music-config--m3u-labels-boundary-comma-in-name () + "Boundary: a comma inside the label is preserved (split on the first only)." + (let ((text "#EXTINF:1,Radio, the Good Kind\nhttps://x.example/s\n")) + (should (equal (cj/music--m3u-labels text) + '(("https://x.example/s" . "Radio, the Good Kind")))))) + +(provide 'test-music-config--m3u-labels) +;;; test-music-config--m3u-labels.el ends here diff --git a/tests/test-music-config--m3u-text.el b/tests/test-music-config--m3u-text.el new file mode 100644 index 00000000..14c9f2bf --- /dev/null +++ b/tests/test-music-config--m3u-text.el @@ -0,0 +1,93 @@ +;;; test-music-config--m3u-text.el --- playlist .m3u emitter tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The custom .m3u emitter behind playlist save. The stock EMMS m3u writer +;; emits bare URLs, which would throw away a station's name/uuid/favicon on +;; save; this emitter writes the same #EXTINF / #RADIOBROWSERUUID / +;; #RADIOBROWSERFAVICON lines the parser (`cj/music--m3u-entries') reads, so +;; save -> load round-trips a station's display name and cover-art metadata. +;; Metadata comes from track properties first, the m3u-scan entries as +;; fallback (a loaded legacy playlist has entries but no properties). + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(declare-function cj/music--m3u-text "music-config" (tracks entries)) +(declare-function cj/music-radio--station-track "music-config" (st)) + +(ert-deftest test-music-m3u-text-normal-file-track-bare-path () + "Normal: a file track is a bare absolute path under the #EXTM3U header." + (let ((text (cj/music--m3u-text (list (emms-track 'file "/music/a.flac")) nil))) + (should (string-prefix-p "#EXTM3U\n" text)) + (should (string-match-p "^/music/a\\.flac$" text)))) + +(ert-deftest test-music-m3u-text-normal-url-track-from-properties () + "Normal: a url track with properties emits uuid, favicon, EXTINF, and url." + (let* ((track (cj/music-radio--station-track + '(:name "Groove Salad" :url "https://ck.somafm.com/gs" + :stationuuid "uuid-1" :favicon "https://somafm.com/i.png"))) + (text (cj/music--m3u-text (list track) nil))) + (should (string-match-p "^#RADIOBROWSERUUID:uuid-1$" text)) + (should (string-match-p "^#RADIOBROWSERFAVICON:https://somafm\\.com/i\\.png$" text)) + (should (string-match-p "^#EXTINF:-1,Groove Salad$" text)) + (should (string-match-p "^https://ck\\.somafm\\.com/gs$" text)))) + +(ert-deftest test-music-m3u-text-normal-url-track-from-entries-fallback () + "Normal: a propertyless url track (a loaded legacy playlist) resolves its +metadata from the ENTRIES alist." + (let* ((url "https://legacy.example/stream") + (track (emms-track 'url url)) + (entries (list (list url :name "Legacy FM" :uuid "uuid-9" + :favicon "https://legacy.example/f.ico"))) + (text (cj/music--m3u-text (list track) entries))) + (should (string-match-p "^#RADIOBROWSERUUID:uuid-9$" text)) + (should (string-match-p "^#EXTINF:-1,Legacy FM$" text)))) + +(ert-deftest test-music-m3u-text-boundary-url-track-no-metadata () + "Boundary: a url track with neither properties nor entries still gets an +EXTINF label (the tidied host) and no uuid/favicon lines." + (let ((text (cj/music--m3u-text + (list (emms-track 'url "https://ice6.somafm.com/live")) nil))) + (should (string-match-p "^#EXTINF:-1,somafm\\.com$" text)) + (should-not (string-match-p "RADIOBROWSERUUID" text)) + (should-not (string-match-p "RADIOBROWSERFAVICON" text)))) + +(ert-deftest test-music-m3u-text-normal-mixed-order-preserved () + "Normal: a mixed queue keeps its track order in the file." + (let* ((f (emms-track 'file "/music/b.mp3")) + (u (cj/music-radio--station-track '(:name "S" :url "https://s.example/x"))) + (text (cj/music--m3u-text (list f u) nil))) + (should (< (string-match "^/music/b\\.mp3$" text) + (string-match "^https://s\\.example/x$" text))))) + +(ert-deftest test-music-m3u-text-round-trip-through-parser () + "Normal: the parser recovers name, uuid, and favicon from emitted text." + (let* ((track (cj/music-radio--station-track + '(:name "Round Trip" :url "https://rt.example/s" + :stationuuid "uuid-rt" :favicon "https://rt.example/f.png"))) + (entries (cj/music--m3u-entries (cj/music--m3u-text (list track) nil))) + (meta (cdr (assoc "https://rt.example/s" entries)))) + (should (equal (plist-get meta :name) "Round Trip")) + (should (equal (plist-get meta :uuid) "uuid-rt")) + (should (equal (plist-get meta :favicon) "https://rt.example/f.png")))) + +(ert-deftest test-music-m3u-text-boundary-empty-playlist-header-only () + "Boundary: an empty track list is just the #EXTM3U header." + (should (equal (cj/music--m3u-text nil nil) "#EXTM3U\n"))) + +(provide 'test-music-config--m3u-text) +;;; test-music-config--m3u-text.el ends here diff --git a/tests/test-music-config--music-files-recursive.el b/tests/test-music-config--music-files-recursive.el new file mode 100644 index 00000000..f5f5fc5b --- /dev/null +++ b/tests/test-music-config--music-files-recursive.el @@ -0,0 +1,88 @@ +;;; test-music-config--music-files-recursive.el --- Tests for filtered directory collection -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Directory adds used to hand the whole tree to emms-add-directory-tree, +;; which adds every file it finds -- cover.jpg and friends ended up as +;; playlist rows. The filtered walk returns only files passing +;; cj/music--valid-file-p, skipping hidden dirs/files, sorted. Real temp-dir +;; fixtures; the EMMS boundary is mocked only in the command-level test. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defmacro test-music-files--with-fixture (var &rest body) + "Run BODY with VAR bound to a temp music-directory fixture." + (declare (indent 1)) + `(let ((,var (make-temp-file "music-test-" t))) + (unwind-protect + (progn + (make-directory (expand-file-name "album" ,var)) + (make-directory (expand-file-name ".hidden" ,var)) + (dolist (f '("song.mp3" "cover.jpg" "album/track.flac" + "album/folder.png" "album/notes.txt" + ".hidden/secret.mp3" ".stray.ogg")) + (write-region "" nil (expand-file-name f ,var))) + ,@body) + (delete-directory ,var t)))) + +;;; Normal Cases + +(ert-deftest test-music-files-recursive-music-only () + "Normal: only files with accepted music extensions come back, sorted; +cover art, text files, and hidden entries stay out." + (test-music-files--with-fixture root + (should (equal (mapcar (lambda (f) (file-relative-name f root)) + (cj/music--music-files-recursive root)) + '("album/track.flac" "song.mp3"))))) + +(ert-deftest test-music-add-directory-recursive-adds-only-music () + "Normal: the directory-add command feeds only music files to EMMS." + (test-music-files--with-fixture root + (let (added) + (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) + (lambda () (current-buffer))) + ((symbol-function 'emms-add-file) + (lambda (f) (push f added)))) + (cj/music-add-directory-recursive root)) + (should (equal (mapcar (lambda (f) (file-relative-name f root)) + (nreverse added)) + '("album/track.flac" "song.mp3")))))) + +;;; Boundary Cases + +(ert-deftest test-music-files-recursive-case-insensitive-extensions () + "Boundary: extensions match case-insensitively (Song.MP3 counts)." + (let ((root (make-temp-file "music-test-case-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "Song.MP3" root)) + (should (= 1 (length (cj/music--music-files-recursive root))))) + (delete-directory root t)))) + +(ert-deftest test-music-files-recursive-empty-directory () + "Boundary: a directory with no music files returns nil." + (let ((root (make-temp-file "music-test-empty-" t))) + (unwind-protect + (progn + (write-region "" nil (expand-file-name "readme.txt" root)) + (should-not (cj/music--music-files-recursive root))) + (delete-directory root t)))) + +;;; Error Cases + +(ert-deftest test-music-add-directory-recursive-not-a-directory-errors () + "Error: a non-directory argument signals user-error." + (should-error (cj/music-add-directory-recursive "/nonexistent/nowhere") + :type 'user-error)) + +(provide 'test-music-config--music-files-recursive) +;;; test-music-config--music-files-recursive.el ends here diff --git a/tests/test-music-config--pin-point.el b/tests/test-music-config--pin-point.el new file mode 100644 index 00000000..2d6fa916 --- /dev/null +++ b/tests/test-music-config--pin-point.el @@ -0,0 +1,78 @@ +;;; test-music-config--pin-point.el --- Tests for the playlist gutter cursor -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The playlist cursor lives pinned at the start of the row (the number +;; gutter). The rows are rendered track lines, not editable text, and +;; vertical motion over thumbnails and stretch-space drifts point to +;; arbitrary visual columns (usually line end). A buffer-local +;; post-command snap enforces the model for every motion command. The one +;; exception is an active isearch, which owns point placement until it ends. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +;;; Normal Cases + +(ert-deftest test-music-pin-point-snaps-mid-line-to-bol () + "Normal: point mid-row snaps back to the beginning of the line." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-char 5) + (cj/music--pin-point-to-bol) + (should (bolp)) + (should (= (point) (point-min))))) + +(ert-deftest test-music-pin-point-noop-at-bol () + "Normal: point already at the row start stays put." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-line 1) + (let ((before (point))) + (cj/music--pin-point-to-bol) + (should (= (point) before))))) + +;;; Boundary Cases + +(ert-deftest test-music-pin-point-skips-during-isearch () + "Boundary: an active isearch owns point; the pin defers until it ends." + (with-temp-buffer + (insert "track one\ntrack two\n") + (goto-char (point-min)) + (forward-char 5) + (let ((isearch-mode t)) + (cj/music--pin-point-to-bol)) + (should-not (bolp)))) + +(ert-deftest test-music-pin-point-empty-buffer-no-error () + "Boundary: an empty buffer is a no-op, no error." + (with-temp-buffer + (should-not (cj/music--pin-point-to-bol)) + (should (bolp)))) + +;;; Hook wiring + +(ert-deftest test-music-pin-point-ensure-wires-post-command-hook () + "Normal: the playlist buffer gets the pin on its buffer-local +post-command-hook." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--pin-point-to-bol post-command-hook)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--pin-point) +;;; test-music-config--pin-point.el ends here diff --git a/tests/test-music-config--playlist-dock.el b/tests/test-music-config--playlist-dock.el new file mode 100644 index 00000000..1dbe9fbb --- /dev/null +++ b/tests/test-music-config--playlist-dock.el @@ -0,0 +1,114 @@ +;;; test-music-config--playlist-dock.el --- Tests for the F10 playlist dock -*- lexical-binding: t; -*- + +;;; Commentary: +;; The F10 playlist always docks at the bottom, whatever the frame's shape. +;; It used to pick `right' on a wide frame via `cj/preferred-dock-direction', +;; which produced an unwanted three-way split on a wide terminal. +;; +;; `cj/side-window-display' is the window-system boundary here, so it is the +;; thing stubbed (an ordinary defun -- safe to `cl-letf', unlike the frame-* +;; subrs). Stubbing it lets these tests assert what the toggle *asks for* +;; without needing a live frame under `--batch'. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'music-config) + +(defmacro test-music-dock--with-captured-side (captured &rest body) + "Run BODY with the playlist display path stubbed, recording its args in CAPTURED. +CAPTURED is set to a plist of :side, :size-var and :default-size." + (declare (indent 1)) + `(let ((buffer (generate-new-buffer " *test-playlist*"))) + (unwind-protect + (cl-letf (((symbol-function 'cj/emms--setup) (lambda (&rest _) nil)) + ((symbol-function 'cj/music--ensure-playlist-buffer) + (lambda (&rest _) buffer)) + ((symbol-function 'emms-playlist-mode-center-current) + (lambda (&rest _) nil)) + ((symbol-function 'cj/side-window-display) + (lambda (_buf side size-var default-size) + (setq ,captured (list :side side :size-var size-var + :default-size default-size)) + (selected-window)))) + ,@body) + (kill-buffer buffer)))) + +(ert-deftest test-music-config-playlist-toggle-docks-bottom-on-wide-frame () + "Normal: a wide frame still docks the playlist at the bottom. +A wide frame used to dock right, splitting the frame three ways." + (let (captured) + (test-music-dock--with-captured-side captured + (cl-letf (((symbol-function 'frame-width) (lambda (&rest _) 400))) + (cj/music-playlist-toggle))) + (should (eq 'bottom (plist-get captured :side))))) + +(ert-deftest test-music-config-playlist-toggle-docks-bottom-on-narrow-frame () + "Boundary: a narrow frame docks at the bottom, as it always did." + (let (captured) + (test-music-dock--with-captured-side captured + (cl-letf (((symbol-function 'frame-width) (lambda (&rest _) 40))) + (cj/music-playlist-toggle))) + (should (eq 'bottom (plist-get captured :side))))) + +(ert-deftest test-music-config-playlist-toggle-uses-height-memory () + "Normal: the bottom dock carries the height fraction and its memory var." + (let (captured) + (test-music-dock--with-captured-side captured + (cj/music-playlist-toggle)) + (should (eq 'cj/--music-playlist-height (plist-get captured :size-var))) + (should (= cj/music-playlist-window-height (plist-get captured :default-size))))) + +(ert-deftest test-music-config-playlist-dock-has-no-width-knobs () + "Error: the right-dock width variables are gone, not merely unused. +A stale `cj/music-playlist-window-width' would read as a live knob that +silently does nothing." + (should-not (boundp 'cj/music-playlist-window-width)) + (should-not (boundp 'cj/--music-playlist-width)) + (should-not (fboundp 'cj/--music-playlist-side))) + +(ert-deftest test-music-config-playlist-default-height-is-half () + "Normal: the dock opens at half the frame height by default (Craig, +2026-07-18 -- a third still read too short for a real playlist)." + (should (= cj/music-playlist-window-height 0.5))) + +(ert-deftest test-music-config-playlist-toggle-off-discards-shrunk-height () + "Error: a captured height below the default is discarded. Window churn +squeezes the dock, and remembering the squeeze reopens it too short on +every later toggle." + (let ((buffer (generate-new-buffer " *test-playlist-shrink*")) + (cj/--music-playlist-height nil)) + (unwind-protect + (save-window-excursion + (set-window-buffer (selected-window) buffer) + (let ((cj/music-playlist-buffer-name (buffer-name buffer))) + (cl-letf (((symbol-function 'cj/side-window-capture-size) + (lambda (_w _side var) (set var 0.2))) + ((symbol-function 'delete-window) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/music-playlist-toggle))) + (should (null cj/--music-playlist-height))) + (kill-buffer buffer)))) + +(ert-deftest test-music-config-playlist-toggle-off-keeps-enlarged-height () + "Normal: a captured height at or above the default is remembered, so a +deliberate enlargement sticks for the session." + (let ((buffer (generate-new-buffer " *test-playlist-grow*")) + (cj/--music-playlist-height nil)) + (unwind-protect + (save-window-excursion + (set-window-buffer (selected-window) buffer) + (let ((cj/music-playlist-buffer-name (buffer-name buffer))) + (cl-letf (((symbol-function 'cj/side-window-capture-size) + (lambda (_w _side var) (set var 0.5))) + ((symbol-function 'delete-window) #'ignore) + ((symbol-function 'message) #'ignore)) + (cj/music-playlist-toggle))) + (should (= 0.5 cj/--music-playlist-height))) + (kill-buffer buffer)))) + +(provide 'test-music-config--playlist-dock) +;;; test-music-config--playlist-dock.el ends here diff --git a/tests/test-music-config--playlist-open-position.el b/tests/test-music-config--playlist-open-position.el new file mode 100644 index 00000000..cd83e65b --- /dev/null +++ b/tests/test-music-config--playlist-open-position.el @@ -0,0 +1,147 @@ +;;; test-music-config--playlist-open-position.el --- Tests for playlist landing position -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Opening the playlist lands point by one rule: the beginning of the playing +;; track's line when a song is playing, else the top of the list. The old +;; behavior keyed off EMMS's selected track, which stays set while stopped, so +;; the playlist opened deep in the list at a stale position. The decision is +;; a pure helper; the window landing (point + upper-third recenter) is tested +;; with recenter stubbed at the display boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +;; Declare the emms vars special HERE too: the module's bare (defvar +;; emms-player-playing-p) marks them special only for code compiled in +;; that file, so a plain `let' in this lexical-binding test file would +;; bind them lexically and the module would never see the value (the +;; scope-shadowing trap from the testing rules). +(defvar emms-player-playing-p) +(defvar emms-playlist-selected-marker) + +(require 'music-config) + +(defmacro test-music-open-pos--with-buffer (var &rest body) + "Run BODY with VAR bound to a temp 3-track playlist-shaped buffer." + (declare (indent 1)) + `(let ((,var (generate-new-buffer " *test-open-pos*"))) + (unwind-protect + (progn + (with-current-buffer ,var + (insert "track one\ntrack two\ntrack three\n")) + ,@body) + (when (buffer-live-p ,var) (kill-buffer ,var))))) + +(defun test-music-open-pos--marker (buffer line offset) + "Marker in BUFFER at LINE (1-based) plus OFFSET chars." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (forward-line (1- line)) + (forward-char offset) + (point-marker)))) + +;;; Normal Cases + +(ert-deftest test-music-playlist-open-position-playing-lands-on-playing-line-start () + "Normal: playing -> the playing track's line, at its beginning (even when +the marker sits mid-line)." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 2 4))) + (should (= (cj/music--playlist-open-position buf) + (with-current-buffer buf + (save-excursion (goto-char (point-min)) (forward-line 1) (point)))))))) + +(ert-deftest test-music-playlist-open-position-stopped-lands-at-top () + "Normal: not playing -> top of the list, even though EMMS still has a +stale selected track." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 3 0))) + (should (= (cj/music--playlist-open-position buf) 1))))) + +;;; Boundary Cases + +(ert-deftest test-music-playlist-open-position-playing-no-marker-lands-at-top () + "Boundary: playing but no usable marker -> top of the list." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker nil)) + (should (= (cj/music--playlist-open-position buf) 1))))) + +(ert-deftest test-music-playlist-open-position-marker-in-other-buffer-lands-at-top () + "Boundary: a marker pointing into a different buffer is ignored." + (test-music-open-pos--with-buffer buf + (with-temp-buffer + (insert "elsewhere\n") + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (point-marker))) + (should (= (cj/music--playlist-open-position buf) 1)))))) + +(ert-deftest test-music-playlist-open-position-empty-buffer () + "Boundary: an empty playlist lands at point-min without error." + (let ((buf (generate-new-buffer " *test-open-pos-empty*"))) + (unwind-protect + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker nil)) + (should (= (cj/music--playlist-open-position buf) 1))) + (kill-buffer buf)))) + +;;; Landing (window boundary stubbed) + +(ert-deftest test-music-playlist-land-point-playing-recenter-upper-third () + "Normal: landing on a playing row sets window point to its line start and +recenters into the upper third." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p t) + (emms-playlist-selected-marker (test-music-open-pos--marker buf 2 4)) + (recenter-arg 'not-called)) + (save-window-excursion + (set-window-buffer (selected-window) buf) + (cl-letf (((symbol-function 'recenter) + (lambda (&optional arg &rest _) (setq recenter-arg arg)))) + (cj/music--playlist-land-point (selected-window) buf)) + (should (= (window-point (selected-window)) + (with-current-buffer buf + (save-excursion (goto-char (point-min)) (forward-line 1) (point))))) + (should (integerp recenter-arg)) + (should (>= recenter-arg 1)))))) + +(ert-deftest test-music-playlist-land-point-stopped-top-no-recenter () + "Normal: landing while stopped puts window point at the top; no recenter." + (test-music-open-pos--with-buffer buf + (let ((emms-player-playing-p nil) + (emms-playlist-selected-marker nil) + (recenter-called nil)) + (save-window-excursion + (set-window-buffer (selected-window) buf) + (cl-letf (((symbol-function 'recenter) + (lambda (&rest _) (setq recenter-called t)))) + (cj/music--playlist-land-point (selected-window) buf)) + (should (= (window-point (selected-window)) 1)) + (should-not recenter-called))))) + +;;; hl-line in the playlist buffer + +(ert-deftest test-music-playlist-ensure-enables-hl-line () + "Normal: the playlist buffer gets hl-line-mode so the current row is +findable even when the cursor sits on album art." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should hl-line-mode))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--playlist-open-position) +;;; test-music-config--playlist-open-position.el ends here diff --git a/tests/test-music-config--playlist-side.el b/tests/test-music-config--playlist-side.el deleted file mode 100644 index f4969469..00000000 --- a/tests/test-music-config--playlist-side.el +++ /dev/null @@ -1,45 +0,0 @@ -;;; test-music-config--playlist-side.el --- Tests for the F10 dock-side helper -*- lexical-binding: t; -*- - -;;; Commentary: -;; `cj/--music-playlist-side' maps the shared dock rule's verdict to a -;; `display-buffer-in-side-window' side: `right' stays `right', anything -;; else becomes `bottom'. The decision itself lives in -;; `cj/preferred-dock-direction' (tested in test-cj-window-geometry-lib.el); -;; here we stub it (an ordinary defun -- safe to `cl-letf', unlike the -;; frame-* subrs) to prove the mapping and that the width fraction is -;; passed through. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'music-config) - -(ert-deftest test-music-config--playlist-side-right-verdict-is-right () - "Normal: a `right' verdict from the dock rule docks the playlist right." - (cl-letf (((symbol-function 'cj/preferred-dock-direction) - (lambda (&rest _) 'right))) - (should (eq (cj/--music-playlist-side) 'right)))) - -(ert-deftest test-music-config--playlist-side-below-verdict-is-bottom () - "Normal: a `below' verdict maps to the `bottom' side window." - (cl-letf (((symbol-function 'cj/preferred-dock-direction) - (lambda (&rest _) 'below))) - (should (eq (cj/--music-playlist-side) 'bottom)))) - -(ert-deftest test-music-config--playlist-side-passes-width-fraction () - "Normal: the playlist's width fraction reaches the dock rule." - (let ((cj/music-playlist-window-width 0.4) - captured) - (cl-letf (((symbol-function 'cj/preferred-dock-direction) - (lambda (cols frac &rest _) - (setq captured (list cols frac)) - 'below))) - (cj/--music-playlist-side) - (should (= (nth 1 captured) 0.4)) - (should (integerp (nth 0 captured)))))) - -(provide 'test-music-config--playlist-side) -;;; test-music-config--playlist-side.el ends here diff --git a/tests/test-music-config--radio-station-track.el b/tests/test-music-config--radio-station-track.el new file mode 100644 index 00000000..5816c776 --- /dev/null +++ b/tests/test-music-config--radio-station-track.el @@ -0,0 +1,135 @@ +;;; test-music-config--radio-station-track.el --- station->track + enqueue tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The queue-first radio model: a picked station becomes an EMMS url track +;; carrying its metadata as track properties (info-title, radio-uuid, +;; radio-favicon) instead of being written to an .m3u. Covers the pure +;; station->track builder and the enqueue-and-play buffer mechanics (with +;; playback mocked at the EMMS boundary). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(declare-function cj/music-radio--station-track "music-config" (st)) +(declare-function cj/music-radio--enqueue-and-play "music-config" (tracks)) + +;;; --------------------------- station-track ----------------------------------- + +(ert-deftest test-music-radio-station-track-normal () + "Normal: a full station plist yields a url track with all three properties." + (let ((track (cj/music-radio--station-track + '(:name "Adroit Jazz Underground" + :url_resolved "https://icecast.walmradio.com:8443/jazz" + :stationuuid "ea8059be-d119" + :favicon "https://walmradio.com/icon.png")))) + (should (eq (emms-track-type track) 'url)) + (should (equal (emms-track-name track) "https://icecast.walmradio.com:8443/jazz")) + (should (equal (emms-track-get track 'info-title) "Adroit Jazz Underground")) + (should (equal (emms-track-get track 'radio-uuid) "ea8059be-d119")) + (should (equal (emms-track-get track 'radio-favicon) "https://walmradio.com/icon.png")))) + +(ert-deftest test-music-radio-station-track-no-url-is-nil () + "Error: a station with no stream URL yields nil, not a broken track." + (should-not (cj/music-radio--station-track '(:name "No URL" :url_resolved "" :url "")))) + +(ert-deftest test-music-radio-station-track-boundary-no-name () + "Boundary: a nameless station falls back to \"Radio\" for its title." + (let ((track (cj/music-radio--station-track '(:url "https://s.example/live")))) + (should (equal (emms-track-get track 'info-title) "Radio")))) + +(ert-deftest test-music-radio-station-track-boundary-newline-name-stripped () + "Boundary: newlines in an external station name are flattened to spaces." + (let ((track (cj/music-radio--station-track + '(:name "Line\nBreak" :url "https://s.example/live")))) + (should (equal (emms-track-get track 'info-title) "Line Break")))) + +(ert-deftest test-music-radio-station-track-boundary-empty-uuid-favicon-absent () + "Boundary: empty-string uuid/favicon are treated as absent, not stored." + (let ((track (cj/music-radio--station-track + '(:name "X" :url "https://s.example/live" :stationuuid "" :favicon "")))) + (should-not (emms-track-get track 'radio-uuid)) + (should-not (emms-track-get track 'radio-favicon)))) + +;;; ------------------------- enqueue-and-play ---------------------------------- + +(defmacro test-music-radio--with-playlist (&rest body) + "Run BODY with a fresh, uniquely named playlist buffer and playback mocked." + `(let* ((cj/music-playlist-buffer-name + (generate-new-buffer-name "*test-radio-enqueue*")) + (emms-player-playing-p nil) + (started 0) (stopped 0)) + (unwind-protect + (cl-letf (((symbol-function 'emms-start) + (lambda () (setq started (1+ started)))) + ((symbol-function 'emms-stop) + (lambda () (setq stopped (1+ stopped))))) + ,@body) + (when (get-buffer cj/music-playlist-buffer-name) + (kill-buffer cj/music-playlist-buffer-name))))) + +(ert-deftest test-music-radio-enqueue-and-play-normal-appends-and-plays () + "Normal: tracks land in the playlist buffer in order; the first is selected +and playback starts." + (test-music-radio--with-playlist + (let ((t1 (cj/music-radio--station-track '(:name "One" :url "https://one.example/a"))) + (t2 (cj/music-radio--station-track '(:name "Two" :url "https://two.example/b")))) + (cj/music-radio--enqueue-and-play (list t1 t2)) + (with-current-buffer cj/music-playlist-buffer-name + (let ((names '())) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when-let ((tr (emms-playlist-track-at (point)))) + (push (emms-track-name tr) names)) + (forward-line 1))) + (should (equal (nreverse names) + '("https://one.example/a" "https://two.example/b")))) + (should (equal (emms-track-name (emms-playlist-selected-track)) + "https://one.example/a"))) + (should (= started 1))))) + +(ert-deftest test-music-radio-enqueue-and-play-boundary-appends-after-existing () + "Boundary: an existing queue is kept; new tracks append and the first NEW +track is the one selected." + (test-music-radio--with-playlist + (let ((old (cj/music-radio--station-track '(:name "Old" :url "https://old.example/x"))) + (new (cj/music-radio--station-track '(:name "New" :url "https://new.example/y")))) + (cj/music-radio--enqueue-and-play (list old)) + (cj/music-radio--enqueue-and-play (list new)) + (with-current-buffer cj/music-playlist-buffer-name + (should (equal (emms-track-name (emms-playlist-selected-track)) + "https://new.example/y")))))) + +(ert-deftest test-music-radio-enqueue-and-play-interrupts-current-playback () + "Normal: when something is playing, enqueue stops it before starting." + (test-music-radio--with-playlist + (let ((emms-player-playing-p t) + (tr (cj/music-radio--station-track '(:name "Z" :url "https://z.example/s")))) + (cj/music-radio--enqueue-and-play (list tr)) + (should (= stopped 1)) + (should (= started 1))))) + +(ert-deftest test-music-radio-enqueue-and-play-boundary-nil-is-no-op () + "Boundary: an empty track list does nothing — no buffer churn, no playback." + (test-music-radio--with-playlist + (cj/music-radio--enqueue-and-play nil) + (should (= started 0)) + (should (= stopped 0)))) + +(provide 'test-music-config--radio-station-track) +;;; test-music-config--radio-station-track.el ends here diff --git a/tests/test-music-config--radio-tags.el b/tests/test-music-config--radio-tags.el new file mode 100644 index 00000000..60e1c9d8 --- /dev/null +++ b/tests/test-music-config--radio-tags.el @@ -0,0 +1,79 @@ +;;; test-music-config--radio-tags.el --- Tests for radio-browser tag pre-population -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The tag-search prompt completes over the popular tags fetched from +;; radio-browser's /json/tags endpoint (cached per session). These tests cover +;; the pure pieces: the endpoint URL, the parse (trim + drop-empty + dedupe, +;; since the source data is user-generated and dirty), and the session cache. +;; The network GET is mocked at the boundary. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defconst test-music-radio-tags--fixture + (concat "[{\"name\":\"jazz \",\"stationcount\":300}," + "{\"name\":\" jazz\",\"stationcount\":5}," + "{\"name\":\"\",\"stationcount\":2}," + "{\"name\":\"rock\",\"stationcount\":100}]") + "A recorded /json/tags response with whitespace, empty, and duplicate names.") + +;;; Normal Cases + +(ert-deftest test-music-radio-tags-url-shape () + "Normal: the tags URL targets /json/tags ordered by station count with the limit." + (let* ((cj/music-radio-tag-limit 500) + (u (cj/music-radio--tags-url "de1.api.radio-browser.info"))) + (should (string-match-p "/json/tags" u)) + (should (string-match-p "order=stationcount" u)) + (should (string-match-p "limit=500" u)))) + +(ert-deftest test-music-radio-parse-tags-trims-dedupes-drops-empty () + "Normal: tag names come back trimmed, deduped, and without empties." + (should (equal (cj/music-radio--parse-tags test-music-radio-tags--fixture) + '("jazz" "rock")))) + +(ert-deftest test-music-radio-available-tags-caches-per-session () + "Normal: the fetch runs once; later calls serve the cache." + (let ((cj/music-radio--tags-cache nil) + (calls 0)) + (cl-letf (((symbol-function 'cj/music-radio--http-get) + (lambda (_url) (cl-incf calls) test-music-radio-tags--fixture))) + (should (equal (cj/music-radio--available-tags) '("jazz" "rock"))) + (should (equal (cj/music-radio--available-tags) '("jazz" "rock"))) + (should (= calls 1))))) + +;;; Boundary Cases + +(ert-deftest test-music-radio-parse-tags-empty-array () + "Boundary: an empty tag array parses to nil." + (should-not (cj/music-radio--parse-tags "[]"))) + +;;; Error Cases + +(ert-deftest test-music-radio-available-tags-fetch-failure-returns-nil-and-retries () + "Error: a failed fetch yields nil, leaves the cache empty, and retries next call." + (let ((cj/music-radio--tags-cache nil) + (calls 0)) + (cl-letf (((symbol-function 'cj/music-radio--http-get) + (lambda (_url) (cl-incf calls) nil))) + (should-not (cj/music-radio--available-tags)) + (should-not cj/music-radio--tags-cache) + (should-not (cj/music-radio--available-tags)) + (should (= calls 2))))) + +(ert-deftest test-music-radio-parse-tags-malformed-user-errors () + "Error: a non-JSON body signals user-error, not a raw parse error." + (should-error (cj/music-radio--parse-tags "<html>502</html>") + :type 'user-error)) + +(provide 'test-music-config--radio-tags) +;;; test-music-config--radio-tags.el ends here diff --git a/tests/test-music-config--radio.el b/tests/test-music-config--radio.el new file mode 100644 index 00000000..a91612bf --- /dev/null +++ b/tests/test-music-config--radio.el @@ -0,0 +1,207 @@ +;;; test-music-config--radio.el --- radio-browser lookup pure-logic tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The pure pieces behind the radio-browser search command (spec +;; docs/specs/2026-07-06-radio-browser-lookup-spec.org): parsing a recorded +;; JSON response, picking a station's stream URL, formatting the marginalia +;; annotation (Variant B: codec/bitrate/country/votes/tags), and building the +;; search URL. The station->track builder and the queue mechanics live in +;; test-music-config--radio-station-track.el; the network GET and the +;; interactive command are exercised in the daemon, not here. + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +;; Declare special here too (the module's bare defvar is file-local) so the +;; registration test's `let' binds dynamically. +(defvar marginalia-annotator-registry) + +(require 'music-config) + +(declare-function cj/music-radio--parse-search "music-config" (json-text)) +(declare-function cj/music-radio--station-url "music-config" (st)) +(declare-function cj/music-radio--tags-snippet "music-config" (tags n)) +(declare-function cj/music-radio--format-candidate "music-config" (st)) +(declare-function cj/music-radio--search-url "music-config" (server query)) + +(defconst test-music-radio--fixture + (concat "[{\"stationuuid\":\"ea8059be-d119-4de3-b27b-0d9bd6aedb17\"," + "\"name\":\"Adroit Jazz Underground\",\"url_resolved\":\"https://icecast.walmradio.com:8443/jazz\"," + "\"codec\":\"MP3\",\"bitrate\":320,\"countrycode\":\"US\",\"votes\":174208,\"tags\":\"bebop,hard bop,cool\"}," + "{\"stationuuid\":\"00000000-no-url\",\"name\":\"No URL Station\",\"url_resolved\":\"\",\"url\":\"\"," + "\"codec\":\"AAC\",\"bitrate\":0,\"countrycode\":\"FR\",\"votes\":5,\"tags\":\"\"}]") + "A two-station recorded radio-browser search response.") + +(defun test-music-radio--first () + "First station plist from the fixture." + (car (cj/music-radio--parse-search test-music-radio--fixture))) + +;;; --------------------------- parse-search ----------------------------------- + +(ert-deftest test-music-radio-parse-search-normal () + "Normal: a recorded response parses to station plists with the expected fields." + (let ((stations (cj/music-radio--parse-search test-music-radio--fixture))) + (should (= (length stations) 2)) + (should (equal (plist-get (car stations) :name) "Adroit Jazz Underground")) + (should (equal (plist-get (car stations) :stationuuid) + "ea8059be-d119-4de3-b27b-0d9bd6aedb17")))) + +(ert-deftest test-music-radio-parse-search-empty () + "Boundary: an empty result array parses to nil." + (should-not (cj/music-radio--parse-search "[]"))) + +(ert-deftest test-music-radio-parse-search-malformed-user-errors () + "Error: a non-JSON body (a gateway page) signals user-error, not a raw parse error." + (should-error (cj/music-radio--parse-search "<html>502 Bad Gateway</html>") + :type 'user-error)) + +;;; --------------------------- station-url ------------------------------------ + +(ert-deftest test-music-radio-station-url-resolved () + "Normal: url_resolved wins when present." + (should (equal (cj/music-radio--station-url (test-music-radio--first)) + "https://icecast.walmradio.com:8443/jazz"))) + +(ert-deftest test-music-radio-station-url-fallback-to-url () + "Boundary: an empty url_resolved falls back to url." + (should (equal (cj/music-radio--station-url + '(:url_resolved "" :url "http://fallback.test/stream")) + "http://fallback.test/stream"))) + +(ert-deftest test-music-radio-station-url-none () + "Error: neither url_resolved nor url yields nil." + (should-not (cj/music-radio--station-url '(:url_resolved "" :url "")))) + +;;; --------------------------- tags-snippet ----------------------------------- + +(ert-deftest test-music-radio-tags-snippet-takes-first-n () + "Normal: the first N comma-separated tags render trimmed." + (should (equal (cj/music-radio--tags-snippet "bebop, hard bop, cool, free jazz" 3) + "bebop, hard bop, cool"))) + +(ert-deftest test-music-radio-tags-snippet-empty () + "Boundary: empty or nil tags render as the empty string." + (should (equal (cj/music-radio--tags-snippet "" 3) "")) + (should (equal (cj/music-radio--tags-snippet nil 3) ""))) + +;;; --------------------------- format-candidate (Variant B) ------------------- + +(ert-deftest test-music-radio-format-candidate-variant-b () + "Normal: the annotation carries codec, votes, and tags (Variant B)." + (let ((ann (cj/music-radio--format-candidate (test-music-radio--first)))) + (should (string-match-p "MP3" ann)) + (should (string-match-p "174208" ann)) + (should (string-match-p "bebop" ann)))) + +;;; --------------------------- search-url ------------------------------------- + +(ert-deftest test-music-radio-search-url-encodes-query-and-limit () + "Normal: the search URL hex-encodes the query and carries the limit; name is the default field." + (let* ((cj/music-radio-search-limit 30) + (u (cj/music-radio--search-url "de1.api.radio-browser.info" "smooth jazz"))) + (should (string-match-p "name=smooth%20jazz" u)) + (should (string-match-p "limit=30" u)) + (should (string-match-p "/json/stations/search" u)))) + +(ert-deftest test-music-radio-search-url-tag-field () + "Normal: field \"tag\" searches the tag= parameter instead of name=." + (let ((u (cj/music-radio--search-url "de1.api.radio-browser.info" "ambient" "tag"))) + (should (string-match-p "tag=ambient" u)) + (should-not (string-match-p "name=ambient" u)))) + +(declare-function cj/music-radio--candidates "music-config" (stations)) + +;;; --------------------------- candidates (dedup) ----------------------------- + +(ert-deftest test-music-radio-candidates-distinct () + "Normal: distinct station names produce distinct display keys mapping to their stations." + (let* ((stations '((:name "Jazz Radio" :codec "MP3" :bitrate 128) + (:name "Blues FM" :codec "AAC" :bitrate 64))) + (cands (cj/music-radio--candidates stations))) + (should (= (length cands) 2)) + (should (assoc "Jazz Radio" cands)) + (should (assoc "Blues FM" cands)))) + +(ert-deftest test-music-radio-candidates-same-name-disambiguated () + "Boundary: two stations with the same name get distinct display keys." + (let* ((stations '((:name "Jazz Radio" :codec "MP3" :bitrate 128 :stationuuid "a") + (:name "Jazz Radio" :codec "OGG" :bitrate 192 :stationuuid "b"))) + (cands (cj/music-radio--candidates stations)) + (keys (mapcar #'car cands))) + (should (= (length cands) 2)) + (should (= (length (delete-dups (copy-sequence keys))) 2)))) + +;;; --------------------------- query whitespace -------------------------------- + +(ert-deftest test-music-radio-search-and-play-trims-query () + "Normal: surrounding whitespace on the query is stripped before the search. +A trailing space in the minibuffer otherwise reaches the API as %20 and +matches nothing." + (let (captured) + (cl-letf (((symbol-function 'cj/emms--setup) #'ignore) + ((symbol-function 'cj/music-radio--search) + (lambda (query _field) (setq captured query) nil))) + (should-error (cj/music-radio--search-and-play " jazz " "tag") + :type 'user-error)) + (should (equal captured "jazz")))) + +(ert-deftest test-music-radio-search-and-play-whitespace-only-no-search () + "Error: a whitespace-only query errors out before any network search." + (let (searched) + (cl-letf (((symbol-function 'cj/emms--setup) #'ignore) + ((symbol-function 'cj/music-radio--search) + (lambda (&rest _) (setq searched t) nil))) + (should-error (cj/music-radio--search-and-play " " "tag") + :type 'user-error)) + (should-not searched))) + +;;; --------------------------- column alignment -------------------------------- + +(ert-deftest test-music-radio-format-candidate-votes-column-fixed-width () + "Normal: the votes field pads to a fixed width so the tags column aligns +across stations with different vote counts." + (let* ((low (cj/music-radio--format-candidate + '(:codec "MP3" :bitrate 128 :countrycode "US" :votes 7 :tags "jazz"))) + (high (cj/music-radio--format-candidate + '(:codec "MP3" :bitrate 128 :countrycode "US" :votes 174208 :tags "jazz")))) + (should (= (string-match "jazz" low) (string-match "jazz" high))))) + +(ert-deftest test-music-radio-completion-table-annotates-station () + "Normal: the table's annotation function returns the Variant-B string for +a station candidate (marginalia handles the right-alignment)." + (let* ((candidates '(("Jazz FM" . (:codec "MP3" :bitrate 128 :countrycode "US" + :votes 5 :tags "jazz")))) + (table (cj/music-radio--completion-table candidates)) + (meta (funcall table "" nil 'metadata)) + (annotate (alist-get 'annotation-function (cdr meta)))) + (should (functionp annotate)) + (should-not (alist-get 'affixation-function (cdr meta))) + (should (string-match-p "MP3" (funcall annotate "Jazz FM"))) + (should (string-match-p "jazz" (funcall annotate "Jazz FM"))))) + +(ert-deftest test-music-radio-completion-table-done-sentinel-no-annotation () + "Boundary: the [done] sentinel has no station and annotates as nil." + (let* ((candidates '(("[done]") ("Station" . (:codec "MP3" :bitrate 128 + :countrycode "US" :votes 1 :tags "x")))) + (table (cj/music-radio--completion-table candidates)) + (annotate (alist-get 'annotation-function + (cdr (funcall table "" nil 'metadata))))) + (should-not (funcall annotate "[done]")))) + +(ert-deftest test-music-radio-completion-table-registers-with-marginalia () + "Normal: building the table registers cj-radio-station so marginalia +right-aligns the table's own annotations." + (let ((marginalia-annotator-registry '())) + (cj/music-radio--completion-table '(("X" . (:codec "MP3")))) + (should (equal (assq 'cj-radio-station marginalia-annotator-registry) + '(cj-radio-station builtin none))))) + +(provide 'test-music-config--radio) +;;; test-music-config--radio.el ends here diff --git a/tests/test-music-config--renumber-rows.el b/tests/test-music-config--renumber-rows.el new file mode 100644 index 00000000..d5bc5141 --- /dev/null +++ b/tests/test-music-config--renumber-rows.el @@ -0,0 +1,232 @@ +;;; test-music-config--renumber-rows.el --- Tests for playlist row numbering -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Playlist rows carry a numeric overlay prefix so the cursor stays visible +;; when it sits on a cover-art thumbnail and each row's position in the list +;; is readable. The renumber walks the buffer and rebuilds the overlays; a +;; buffer-local after-change hook debounces it behind an idle timer. Overlays +;; leave the buffer text untouched (EMMS owns it), so these tests drive plain +;; temp buffers. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'music-config) + +(defun test-music-renumber--numbers (buffer) + "Return the overlay number strings in BUFFER, in position order." + (with-current-buffer buffer + (mapcar (lambda (ov) (overlay-get ov 'before-string)) + (sort (seq-filter (lambda (ov) (overlay-get ov 'cj-music-row-number)) + (overlays-in (point-min) (point-max))) + (lambda (a b) (< (overlay-start a) (overlay-start b))))))) + +;;; Normal Cases + +(ert-deftest test-music-renumber-rows-numbers-each-line () + "Normal: every non-blank line gets a sequential number overlay." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\n") + (cj/music--renumber-rows (current-buffer)) + (should (equal (mapcar #'substring-no-properties + (test-music-renumber--numbers (current-buffer))) + '(" 1 " " 2 " " 3 "))))) + +(ert-deftest test-music-renumber-rows-idempotent () + "Normal: renumbering twice leaves one overlay per line, not two." + (with-temp-buffer + (insert "track one\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (cj/music--renumber-rows (current-buffer)) + (should (= 2 (length (test-music-renumber--numbers (current-buffer))))))) + +(ert-deftest test-music-renumber-rows-number-carries-cursor-property () + "Normal: the number string carries a cursor property. Point is pinned at +the row start, and without the property redisplay draws the cursor after +the before-string -- on the album-art thumbnail, where it's invisible." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (let ((s (car (test-music-renumber--numbers (current-buffer))))) + (should (get-text-property 0 'cursor s))))) + +;;; Boundary Cases + +(ert-deftest test-music-renumber-rows-skips-blank-lines () + "Boundary: blank lines are not numbered and don't advance the count." + (with-temp-buffer + (insert "track one\n\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (should (equal (mapcar #'substring-no-properties + (test-music-renumber--numbers (current-buffer))) + '(" 1 " " 2 "))))) + +(ert-deftest test-music-renumber-rows-empty-buffer-no-overlays () + "Boundary: an empty buffer gets no overlays and no error." + (with-temp-buffer + (cj/music--renumber-rows (current-buffer)) + (should-not (test-music-renumber--numbers (current-buffer))))) + +;;; Error Cases + +(ert-deftest test-music-renumber-rows-dead-buffer-noop () + "Error: renumbering a killed buffer is a silent no-op (the debounce timer +can fire after the playlist buffer is gone)." + (let ((buf (generate-new-buffer " *test-renumber-dead*"))) + (kill-buffer buf) + (should-not (cj/music--renumber-rows buf)))) + +(ert-deftest test-music-renumber-rows-number-outranks-header-overlay () + "Normal: number overlays carry a priority above the header overlay's 100. +The header block is a same-position overlay string at the buffer start; +without the higher priority, row 1's number renders above the header +instead of next to its own track." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (let ((ov (car (seq-filter (lambda (o) (overlay-get o 'cj-music-row-number)) + (overlays-in (point-min) (point-max)))))) + (should (> (or (overlay-get ov 'priority) 0) 100))))) + +(ert-deftest test-music-ensure-playlist-buffer-logical-line-motion () + "Normal: the playlist moves by logical lines, not screen lines. The +multi-line header overlay string at position 1 otherwise absorbs every +next-line from the top row -- vertical motion steps through the header's +display and maps back to the same buffer position, so arrows look dead." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (local-variable-p 'line-move-visual)) + (should-not line-move-visual))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Current-row indicator + +(ert-deftest test-music-highlight-current-number-marks-current-row () + "Normal: the current row's number renders inverse-video; moving to another +row restores the old one and marks the new one. The block cursor only +draws in the selected window, so the number itself carries the mark." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (forward-line 1) + (cj/music--highlight-current-number) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should-not (plist-get (get-text-property 0 'face (nth 0 numbers)) :inverse-video)) + (should (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video))) + (forward-line 1) + (cj/music--highlight-current-number) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should-not (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video)) + (should (plist-get (get-text-property 0 'face (nth 2 numbers)) :inverse-video))))) + +(ert-deftest test-music-highlight-current-number-survives-renumber () + "Boundary: a renumber rebuilds the overlays; the highlight re-applies to +the current row rather than pointing at a dead overlay." + (with-temp-buffer + (insert "track one\ntrack two\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (forward-line 1) + (cj/music--highlight-current-number) + (cj/music--renumber-rows (current-buffer)) + (let ((numbers (test-music-renumber--numbers (current-buffer)))) + (should (plist-get (get-text-property 0 'face (nth 1 numbers)) :inverse-video))))) + +(ert-deftest test-music-highlight-current-number-keeps-cursor-property () + "Boundary: re-facing a number keeps the cursor property intact." + (with-temp-buffer + (insert "track one\n") + (cj/music--renumber-rows (current-buffer)) + (goto-char (point-min)) + (cj/music--highlight-current-number) + (let ((s (car (test-music-renumber--numbers (current-buffer))))) + (should (get-text-property 0 'cursor s))))) + +(ert-deftest test-music-ensure-playlist-buffer-sticky-hl-line () + "Normal: hl-line in the playlist stays visible when the window isn't +selected -- the dock is glanced at from other windows constantly." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (should (buffer-local-value 'hl-line-sticky-flag created))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Sticky header + +(ert-deftest test-music-stick-header-moves-overlay-to-window-start () + "Normal: a scroll re-anchors the header overlay at the new window start, +so the header block stays at the top of the window while the list scrolls." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\ntrack four\n") + (setq cj/music--header-overlay (make-overlay (point-min) (point-min))) + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (let ((start (save-excursion (goto-char (point-min)) (forward-line 2) (point)))) + (cj/music--stick-header (selected-window) start) + (should (= (overlay-start cj/music--header-overlay) start)) + ;; Converges: the same start again is a no-op, not a loop. + (cj/music--stick-header (selected-window) start) + (should (= (overlay-start cj/music--header-overlay) start)))))) + +(ert-deftest test-music-stick-header-no-overlay-noop () + "Boundary: no header overlay yet -- the scroll handler is a silent no-op." + (with-temp-buffer + (insert "track one\n") + (setq cj/music--header-overlay nil) + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (should-not (cj/music--stick-header (selected-window) (point-min)))))) + +(ert-deftest test-music-header-anchor-position-displayed-vs-not () + "Normal: the header anchors at the displaying window's start; an +undisplayed buffer anchors at the top." + (with-temp-buffer + (insert "track one\ntrack two\ntrack three\ntrack four\n") + (save-window-excursion + (set-window-buffer (selected-window) (current-buffer)) + (let ((start (save-excursion (goto-char (point-min)) (forward-line 2) (point)))) + (set-window-start (selected-window) start) + (should (= (cj/music--header-anchor-position) start)))) + ;; Not displayed after the excursion restores the old config. + (should (= (cj/music--header-anchor-position) (point-min))))) + +(ert-deftest test-music-ensure-playlist-buffer-wires-scroll-hook () + "Normal: the playlist buffer re-sticks its header on every window scroll." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--stick-header window-scroll-functions)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +;;; Hook wiring + +(ert-deftest test-music-renumber-ensure-playlist-buffer-wires-hook () + "Normal: the playlist buffer gets the debounced renumber on after-change." + (let (created) + (cl-letf (((symbol-function 'emms-playlist-mode) #'ignore)) + (unwind-protect + (progn + (setq created (cj/music--ensure-playlist-buffer)) + (with-current-buffer created + (should (member #'cj/music--schedule-renumber after-change-functions)))) + (when (buffer-live-p created) (kill-buffer created)))))) + +(provide 'test-music-config--renumber-rows) +;;; test-music-config--renumber-rows.el ends here diff --git a/tests/test-music-config--safe-filename.el b/tests/test-music-config--safe-filename.el deleted file mode 100644 index 8105ee15..00000000 --- a/tests/test-music-config--safe-filename.el +++ /dev/null @@ -1,97 +0,0 @@ -;;; test-music-config--safe-filename.el --- Tests for filename sanitization -*- coding: utf-8; lexical-binding: t; -*- -;; -;; Author: Craig Jennings <c@cjennings.net> -;; -;;; Commentary: -;; Unit tests for cj/music--safe-filename function. -;; Tests the pure helper that sanitizes filenames by replacing invalid chars. -;; -;; Test organization: -;; - Normal Cases: Valid filenames unchanged, spaces replaced -;; - Boundary Cases: Special chars, unicode, slashes, consecutive invalid chars -;; - Error Cases: Nil input -;; -;;; Code: - -(require 'ert) - -;; Stub missing dependencies before loading music-config -(defvar-keymap cj/custom-keymap - :doc "Stub keymap for testing") - -;; Load production code -(require 'music-config) - -;;; Normal Cases - -(ert-deftest test-music-config--safe-filename-normal-alphanumeric-unchanged () - "Validate alphanumeric filename remains unchanged." - (should (string= (cj/music--safe-filename "MyPlaylist123") - "MyPlaylist123"))) - -(ert-deftest test-music-config--safe-filename-normal-with-hyphens-unchanged () - "Validate filename with hyphens remains unchanged." - (should (string= (cj/music--safe-filename "my-playlist-name") - "my-playlist-name"))) - -(ert-deftest test-music-config--safe-filename-normal-with-underscores-unchanged () - "Validate filename with underscores remains unchanged." - (should (string= (cj/music--safe-filename "my_playlist_name") - "my_playlist_name"))) - -(ert-deftest test-music-config--safe-filename-normal-spaces-replaced () - "Validate spaces are replaced with underscores." - (should (string= (cj/music--safe-filename "My Favorite Songs") - "My_Favorite_Songs"))) - -;;; Boundary Cases - -(ert-deftest test-music-config--safe-filename-boundary-special-chars-replaced () - "Validate special characters are replaced with underscores." - (should (string= (cj/music--safe-filename "playlist@#$%^&*()") - "playlist_________"))) - -(ert-deftest test-music-config--safe-filename-boundary-unicode-replaced () - "Validate unicode characters are replaced with underscores." - (should (string= (cj/music--safe-filename "中文歌曲") - "____"))) - -(ert-deftest test-music-config--safe-filename-boundary-mixed-valid-invalid () - "Validate mixed valid and invalid characters." - (should (string= (cj/music--safe-filename "Rock & Roll") - "Rock___Roll"))) - -(ert-deftest test-music-config--safe-filename-boundary-dots-replaced () - "Validate dots are replaced with underscores." - (should (string= (cj/music--safe-filename "my.playlist.name") - "my_playlist_name"))) - -(ert-deftest test-music-config--safe-filename-boundary-slashes-replaced () - "Validate slashes are replaced with underscores." - (should (string= (cj/music--safe-filename "folder/file") - "folder_file"))) - -(ert-deftest test-music-config--safe-filename-boundary-consecutive-invalid-chars () - "Validate consecutive invalid characters each become underscores." - (should (string= (cj/music--safe-filename "test!!!name") - "test___name"))) - -(ert-deftest test-music-config--safe-filename-boundary-empty-string-unchanged () - "Validate empty string remains unchanged." - (should (string= (cj/music--safe-filename "") - ""))) - -(ert-deftest test-music-config--safe-filename-boundary-only-invalid-chars () - "Validate string with only invalid characters becomes all underscores." - (should (string= (cj/music--safe-filename "!@#$%") - "_____"))) - -;;; Error Cases - -(ert-deftest test-music-config--safe-filename-error-nil-input-signals-error () - "Validate nil input signals error." - (should-error (cj/music--safe-filename nil) - :type 'wrong-type-argument)) - -(provide 'test-music-config--safe-filename) -;;; test-music-config--safe-filename.el ends here diff --git a/tests/test-music-config--save-helpers.el b/tests/test-music-config--save-helpers.el new file mode 100644 index 00000000..ffb0a477 --- /dev/null +++ b/tests/test-music-config--save-helpers.el @@ -0,0 +1,90 @@ +;;; test-music-config--save-helpers.el --- save default-name + directory tests -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; The pure helpers behind the queue-first save flow: which name the save +;; prompt pre-fills (`cj/music--save-default-name') and which directory the +;; file lands in (`cj/music--save-directory'). An all-stream queue saves into +;; the radio playlist home (`cj/music-radio-save-dir'); anything else saves +;; into `cj/music-m3u-root'. + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(declare-function cj/music--save-default-name "music-config" (tracks file entries)) +(declare-function cj/music--save-directory "music-config" (tracks)) +(declare-function cj/music-radio--station-track "music-config" (st)) + +;;; --------------------------- save-default-name ------------------------------- + +(ert-deftest test-music-save-default-name-normal-associated-file-wins () + "Normal: an associated playlist file names the save, station or not." + (let ((tr (cj/music-radio--station-track '(:name "S" :url "https://s.example/x")))) + (should (equal (cj/music--save-default-name (list tr) "/pl/jazz.m3u" nil) + "jazz")))) + +(ert-deftest test-music-save-default-name-normal-station-title () + "Normal: with no file, the first url track's station name pre-fills." + (let ((tr (cj/music-radio--station-track + '(:name "Groove Salad" :url "https://gs.example/x")))) + (should (equal (cj/music--save-default-name (list tr) nil nil) + "Groove Salad")))) + +(ert-deftest test-music-save-default-name-normal-first-url-track-wins () + "Normal: a file track ahead of the station doesn't block the station name; +the first URL track with a name wins." + (let ((f (emms-track 'file "/music/a.flac")) + (tr (cj/music-radio--station-track + '(:name "Second Pick" :url "https://sp.example/x")))) + (should (equal (cj/music--save-default-name (list f tr) nil nil) + "Second Pick")))) + +(ert-deftest test-music-save-default-name-normal-entries-fallback () + "Normal: a propertyless url track resolves its name from ENTRIES." + (let* ((url "https://legacy.example/s") + (tr (emms-track 'url url)) + (entries (list (list url :name "Legacy FM" :uuid nil :favicon nil)))) + (should (equal (cj/music--save-default-name (list tr) nil entries) + "Legacy FM")))) + +(ert-deftest test-music-save-default-name-boundary-no-candidates-nil () + "Boundary: no file, no url tracks -> nil (caller falls back to a timestamp)." + (should-not (cj/music--save-default-name + (list (emms-track 'file "/music/a.flac")) nil nil)) + (should-not (cj/music--save-default-name nil nil nil))) + +;;; ---------------------------- save-directory --------------------------------- + +(ert-deftest test-music-save-directory-normal-all-streams-radio-dir () + "Normal: an all-stream queue saves into the radio playlist dir." + (let ((u1 (emms-track 'url "https://a.example/1")) + (u2 (emms-track 'url "https://b.example/2"))) + (should (equal (cj/music--save-directory (list u1 u2)) + cj/music-radio-save-dir)))) + +(ert-deftest test-music-save-directory-normal-mixed-goes-to-m3u-root () + "Normal: any non-stream track routes the save to the music playlist root." + (let ((u (emms-track 'url "https://a.example/1")) + (f (emms-track 'file "/music/a.flac"))) + (should (equal (cj/music--save-directory (list u f)) + cj/music-m3u-root)))) + +(ert-deftest test-music-save-directory-boundary-empty-goes-to-m3u-root () + "Boundary: an empty queue defaults to the music playlist root." + (should (equal (cj/music--save-directory nil) cj/music-m3u-root))) + +(provide 'test-music-config--save-helpers) +;;; test-music-config--save-helpers.el ends here diff --git a/tests/test-music-config--tidy-host.el b/tests/test-music-config--tidy-host.el new file mode 100644 index 00000000..92b104a6 --- /dev/null +++ b/tests/test-music-config--tidy-host.el @@ -0,0 +1,47 @@ +;;; test-music-config--tidy-host.el --- Tests for stream-URL host tidying -*- coding: utf-8; lexical-binding: t; -*- +;; +;; Author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; Unit tests for `cj/music--tidy-host': reduce a stream URL to a readable host +;; label (scheme dropped, a leading "www." removed), used as the last-resort +;; display name for a url track with no #EXTINF label. +;; +;;; Code: + +(require 'ert) + +(defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) +(require 'music-config) + +(ert-deftest test-music-config--tidy-host-normal () + "Normal: scheme and path are dropped, host kept." + (should (string= (cj/music--tidy-host "https://ice6.somafm.com/groovesalad-256-mp3") + "somafm.com"))) + +(ert-deftest test-music-config--tidy-host-normal-http () + "Normal: plain http host with a port keeps the host, drops the port." + (should (string= (cj/music--tidy-host "http://stream.example.org:8000/live") + "example.org"))) + +(ert-deftest test-music-config--tidy-host-boundary-strip-www () + "Boundary: a leading www. is stripped." + (should (string= (cj/music--tidy-host "https://www.radioparadise.com/m3u/mp3-128.m3u") + "radioparadise.com"))) + +(ert-deftest test-music-config--tidy-host-boundary-bare-domain () + "Boundary: a two-label domain is returned unchanged." + (should (string= (cj/music--tidy-host "http://somafm.com/") "somafm.com"))) + +(ert-deftest test-music-config--tidy-host-error-not-a-url () + "Error: a non-URL string is returned as-is rather than erroring." + (should (string= (cj/music--tidy-host "not a url") "not a url"))) + +(provide 'test-music-config--tidy-host) +;;; test-music-config--tidy-host.el ends here diff --git a/tests/test-music-config--track-description.el b/tests/test-music-config--track-description.el deleted file mode 100644 index a1a1cc6d..00000000 --- a/tests/test-music-config--track-description.el +++ /dev/null @@ -1,181 +0,0 @@ -;;; test-music-config--track-description.el --- Tests for track description -*- coding: utf-8; lexical-binding: t; -*- -;; -;; Author: Craig Jennings <c@cjennings.net> -;; -;;; Commentary: -;; Unit tests for cj/music--track-description function. -;; Tests the custom track description that replaces EMMS's default file-path display -;; with human-readable formats based on track type and available metadata. -;; -;; Track construction: EMMS tracks are alists created with `emms-track' and -;; populated with `emms-track-set'. No playlist buffer or player state needed. -;; -;; Test organization: -;; - Normal Cases: Tagged tracks (artist+title+duration), partial metadata, file fallback, URL -;; - Boundary Cases: Empty strings, missing fields, special characters, long names -;; - Error Cases: Unknown track type fallback -;; -;;; Code: - -(require 'ert) - -;; Stub missing dependencies before loading music-config -(defvar-keymap cj/custom-keymap - :doc "Stub keymap for testing") - -;; Add EMMS elpa directory to load path for batch testing -(let ((emms-dir (car (file-expand-wildcards - (expand-file-name "elpa/emms-*" user-emacs-directory))))) - (when emms-dir - (add-to-list 'load-path emms-dir))) - -(require 'emms) -(require 'emms-playlist-mode) -(require 'music-config) - -;;; Test helpers - -(defun test-track-description--make-file-track (path &optional title artist duration) - "Create a file TRACK with PATH and optional metadata TITLE, ARTIST, DURATION." - (let ((track (emms-track 'file path))) - (when title (emms-track-set track 'info-title title)) - (when artist (emms-track-set track 'info-artist artist)) - (when duration (emms-track-set track 'info-playing-time duration)) - track)) - -(defun test-track-description--make-url-track (url &optional title artist duration) - "Create a URL TRACK with URL and optional metadata TITLE, ARTIST, DURATION." - (let ((track (emms-track 'url url))) - (when title (emms-track-set track 'info-title title)) - (when artist (emms-track-set track 'info-artist artist)) - (when duration (emms-track-set track 'info-playing-time duration)) - track)) - -;;; Normal Cases — Tagged tracks (artist + title + duration) - -(ert-deftest test-music-config--track-description-normal-full-metadata () - "Validate track with artist, title, and duration shows all three." - (let ((track (test-track-description--make-file-track - "/music/Kind of Blue/01 - So What.flac" - "So What" "Miles Davis" 562))) - (should (string= (cj/music--track-description track) - "Miles Davis - So What [9:22]")))) - -(ert-deftest test-music-config--track-description-normal-title-and-artist-no-duration () - "Validate track with artist and title but no duration omits bracket." - (let ((track (test-track-description--make-file-track - "/test/uncached-nodur.mp3" "Blue in Green" "Miles Davis"))) - (should (string= (cj/music--track-description track) - "Miles Davis - Blue in Green")))) - -(ert-deftest test-music-config--track-description-normal-title-only () - "Validate track with title but no artist shows title alone." - (let ((track (test-track-description--make-file-track - "/test/uncached-noartist.mp3" "Flamenco Sketches" nil 566))) - (should (string= (cj/music--track-description track) - "Flamenco Sketches [9:26]")))) - -(ert-deftest test-music-config--track-description-normal-title-only-no-duration () - "Validate track with only title shows just the title." - (let ((track (test-track-description--make-file-track - "/test/uncached-titleonly.mp3" "All Blues"))) - (should (string= (cj/music--track-description track) - "All Blues")))) - -;;; Normal Cases — File tracks without tags - -(ert-deftest test-music-config--track-description-normal-file-no-tags () - "Validate untagged file shows filename without path or extension." - (let ((track (test-track-description--make-file-track - "/music/Kind of Blue/02 - Freddie Freeloader.flac"))) - (should (string= (cj/music--track-description track) - "02 - Freddie Freeloader")))) - -(ert-deftest test-music-config--track-description-normal-file-nested-path () - "Validate deeply nested path still shows only the filename." - (let ((track (test-track-description--make-file-track - "/music/Jazz/Miles Davis/Kind of Blue/01 - So What.mp3"))) - (should (string= (cj/music--track-description track) - "01 - So What")))) - -;;; Normal Cases — URL tracks - -(ert-deftest test-music-config--track-description-normal-url-plain () - "Validate plain URL is shown as-is." - (let ((track (test-track-description--make-url-track - "https://radio.example.com/stream"))) - (should (string= (cj/music--track-description track) - "https://radio.example.com/stream")))) - -(ert-deftest test-music-config--track-description-normal-url-percent-encoded () - "Validate percent-encoded URL characters are decoded." - (let ((track (test-track-description--make-url-track - "https://radio.example.com/my%20station%21"))) - (should (string= (cj/music--track-description track) - "https://radio.example.com/my station!")))) - -(ert-deftest test-music-config--track-description-normal-url-with-tags () - "Validate URL track with tags uses tag display, not URL." - (let ((track (test-track-description--make-url-track - "https://radio.example.com/stream" - "Jazz FM" "Radio Station" 0))) - ;; Duration 0 → nil from format-duration, so no bracket - (should (string= (cj/music--track-description track) - "Radio Station - Jazz FM")))) - -;;; Boundary Cases - -(ert-deftest test-music-config--track-description-boundary-empty-title-string () - "Validate empty title string is still truthy, shows empty result." - (let ((track (test-track-description--make-file-track - "/music/track.mp3" "" "Artist"))) - ;; Empty string is non-nil, so title branch is taken - (should (string= (cj/music--track-description track) - "Artist - ")))) - -(ert-deftest test-music-config--track-description-boundary-file-no-extension () - "Validate file without extension shows full filename." - (let ((track (test-track-description--make-file-track "/music/README"))) - (should (string= (cj/music--track-description track) - "README")))) - -(ert-deftest test-music-config--track-description-boundary-file-multiple-dots () - "Validate file with multiple dots strips only the final extension." - (let ((track (test-track-description--make-file-track - "/music/disc.1.track.03.flac"))) - (should (string= (cj/music--track-description track) - "disc.1.track.03")))) - -(ert-deftest test-music-config--track-description-boundary-unicode-title () - "Validate unicode characters in metadata are preserved." - (let ((track (test-track-description--make-file-track - "/music/track.mp3" "夜に駆ける" "YOASOBI" 258))) - (should (string= (cj/music--track-description track) - "YOASOBI - 夜に駆ける [4:18]")))) - -(ert-deftest test-music-config--track-description-boundary-url-utf8-percent-encoded () - "Validate percent-encoded UTF-8 in URL is decoded correctly." - (let ((track (test-track-description--make-url-track - "https://example.com/caf%C3%A9"))) - (should (string= (cj/music--track-description track) - "https://example.com/café")))) - -(ert-deftest test-music-config--track-description-boundary-short-duration () - "Validate 1-second track formats correctly in bracket." - (let ((track (test-track-description--make-file-track - "/music/t.mp3" "Beep" nil 1))) - (should (string= (cj/music--track-description track) - "Beep [0:01]")))) - -;;; Error Cases - -(ert-deftest test-music-config--track-description-error-unknown-type-fallback () - "Validate unknown track type uses emms-track-simple-description fallback." - (let ((track (emms-track 'streamlist "https://example.com/playlist.m3u"))) - ;; Should not error; falls through to simple-description - (let ((result (cj/music--track-description track))) - (should (stringp result)) - (should (string-match-p "example\\.com" result))))) - -(provide 'test-music-config--track-description) -;;; test-music-config--track-description.el ends here diff --git a/tests/test-music-config-commands.el b/tests/test-music-config-commands.el index 3c585d0b..40fb2d81 100644 --- a/tests/test-music-config-commands.el +++ b/tests/test-music-config-commands.el @@ -30,17 +30,21 @@ ;;; cj/music-add-directory-recursive (ert-deftest test-music-add-directory-recursive-passes-dir-to-emms () - "Normal: add-directory-recursive routes through emms-add-directory-tree." + "Normal: add-directory-recursive feeds the directory's music files (and +only those) to emms-add-file -- the raw-tree path added cover art too." (let* ((tmp (file-name-as-directory (make-temp-file "cj-music-add-" t))) - called) + added) (unwind-protect - (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) #'ignore) - ((symbol-function 'emms-add-directory-tree) - (lambda (dir) (setq called dir))) - ((symbol-function 'message) #'ignore)) - (cj/music-add-directory-recursive tmp)) + (progn + (write-region "" nil (expand-file-name "song.mp3" tmp)) + (write-region "" nil (expand-file-name "cover.jpg" tmp)) + (cl-letf (((symbol-function 'cj/music--ensure-playlist-buffer) #'ignore) + ((symbol-function 'emms-add-file) + (lambda (f) (push f added))) + ((symbol-function 'message) #'ignore)) + (cj/music-add-directory-recursive tmp))) (delete-directory tmp t)) - (should (equal called tmp)))) + (should (equal (mapcar #'file-name-nondirectory added) '("song.mp3"))))) (ert-deftest test-music-add-directory-recursive-errors-on-non-directory () "Error: passing a regular file (not a directory) signals user-error." diff --git a/tests/test-music-config-create-radio-station.el b/tests/test-music-config-create-radio-station.el index 1f4365a4..4f49f49b 100644 --- a/tests/test-music-config-create-radio-station.el +++ b/tests/test-music-config-create-radio-station.el @@ -1,153 +1,131 @@ -;;; test-music-config-create-radio-station.el --- Tests for radio station creation -*- coding: utf-8; lexical-binding: t; -*- +;;; test-music-config-create-radio-station.el --- Tests for manual radio-station entry -*- coding: utf-8; lexical-binding: t; -*- ;; ;; Author: Craig Jennings <c@cjennings.net> ;; ;;; Commentary: -;; Unit tests for cj/music-create-radio-station function. -;; Tests M3U file creation for radio stations with stream URLs. +;; Unit tests for cj/music-create-radio-station under the queue-first model: +;; a hand-entered name + URL becomes a url track in the playlist queue (with +;; the name as its title property) and playback starts. Nothing is written +;; to disk — saving is the normal playlist-save flow. ;; ;; Test organization: -;; - Normal Cases: Standard creation, EXTM3U format, safe filename -;; - Boundary Cases: Unicode name, complex URL, overwrite confirmed -;; - Error Cases: Empty name, empty URL, overwrite declined -;; +;; - Normal Cases: track queued with title, playback started, no file written +;; - Boundary Cases: unicode name preserved verbatim +;; - Error Cases: empty name, empty URL + ;;; Code: (require 'ert) -(require 'testutil-general) +(require 'cl-lib) ;; Stub missing dependencies before loading music-config (defvar-keymap cj/custom-keymap :doc "Stub keymap for testing") -;; Load production code -(require 'music-config) - -;;; Setup & Teardown +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) -(defun test-music-config-create-radio-station-setup () - "Setup test environment with temp directory for M3U output." - (cj/create-test-base-dir) - (cj/create-test-subdirectory "radio-playlists")) +(require 'emms) +(require 'music-config) -(defun test-music-config-create-radio-station-teardown () - "Clean up test environment." - (cj/delete-test-base-dir)) +(defmacro test-music-create-radio--with-env (&rest body) + "Run BODY with a fresh playlist buffer, playback mocked, messages captured." + `(let* ((cj/music-playlist-buffer-name + (generate-new-buffer-name "*test-create-radio*")) + (emms-player-playing-p nil) + (started 0) (msg nil)) + (ignore started msg) + (unwind-protect + (cl-letf (((symbol-function 'emms-start) + (lambda () (setq started (1+ started)))) + ((symbol-function 'emms-stop) #'ignore) + ((symbol-function 'message) + (lambda (fmt &rest args) + (when fmt (setq msg (apply #'format fmt args)))))) + ,@body) + (when (get-buffer cj/music-playlist-buffer-name) + (kill-buffer cj/music-playlist-buffer-name))))) + +(defun test-music-create-radio--queued-tracks () + "Track objects currently in the test playlist buffer." + (let ((tracks '())) + (with-current-buffer cj/music-playlist-buffer-name + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when-let ((tr (emms-playlist-track-at (point)))) + (push tr tracks)) + (forward-line 1)))) + (nreverse tracks))) ;;; Normal Cases -(ert-deftest test-music-config-create-radio-station-normal-creates-m3u-file () - "Creating a radio station produces an M3U file in the music root." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Jazz FM" "http://stream.jazzfm.com/radio") - (let ((expected-file (expand-file-name "Jazz_FM_Radio.m3u" test-dir))) - (should (file-exists-p expected-file)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-normal-extm3u-format () - "Created file contains EXTM3U header, EXTINF with station name, and URL." - (let ((test-dir (test-music-config-create-radio-station-setup))) +(ert-deftest test-music-config-create-radio-station-normal-queues-track () + "Normal: name+url queues a url track carrying the name, and playback starts." + (test-music-create-radio--with-env + (cj/music-create-radio-station "Jazz FM" "http://stream.jazzfm.com/radio") + (let ((tracks (test-music-create-radio--queued-tracks))) + (should (= (length tracks) 1)) + (should (eq (emms-track-type (car tracks)) 'url)) + (should (equal (emms-track-name (car tracks)) "http://stream.jazzfm.com/radio")) + (should (equal (emms-track-get (car tracks) 'info-title) "Jazz FM"))) + (should (= started 1)) + (should (string-match-p "Jazz FM" msg)))) + +(ert-deftest test-music-config-create-radio-station-normal-writes-no-file () + "Normal: nothing lands on disk — saving is the playlist-save flow's job." + (let ((tmp (file-name-as-directory (make-temp-file "cj-radio-nofile-" t)))) (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Jazz FM" "http://stream.jazzfm.com/radio") - (let ((content (with-temp-buffer - (insert-file-contents - (expand-file-name "Jazz_FM_Radio.m3u" test-dir)) - (buffer-string)))) - (should (string-match-p "^#EXTM3U" content)) - (should (string-match-p "#EXTINF:-1,Jazz FM" content)) - (should (string-match-p "http://stream.jazzfm.com/radio" content)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-normal-safe-filename () - "Station name with special characters produces filesystem-safe filename." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Rock & Roll 101.5" "http://example.com/stream") - ;; Spaces and special chars replaced with underscores - (let ((expected-file (expand-file-name "Rock___Roll_101_5_Radio.m3u" test-dir))) - (should (file-exists-p expected-file)))) - (test-music-config-create-radio-station-teardown)))) + (test-music-create-radio--with-env + (let ((cj/music-m3u-root tmp) + (cj/music-radio-save-dir tmp)) + (cj/music-create-radio-station "NPR" "https://example.test/stream") + (should-not (directory-files tmp nil "\\.m3u\\'")))) + (delete-directory tmp t)))) ;;; Boundary Cases -(ert-deftest test-music-config-create-radio-station-boundary-unicode-name-safe-filename () - "Unicode station name produces safe filename while preserving name in EXTINF." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - (cj/music-create-radio-station "Klassik Radio" "http://example.com/stream") - ;; Name is all ASCII-safe, so filename uses it directly - (should (file-exists-p (expand-file-name "Klassik_Radio_Radio.m3u" test-dir))) - ;; Original name preserved in EXTINF inside the file - (let ((content (with-temp-buffer - (insert-file-contents - (expand-file-name "Klassik_Radio_Radio.m3u" test-dir)) - (buffer-string)))) - (should (string-match-p "Klassik Radio" content)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-boundary-url-with-query-params () - "Complex URL with query parameters preserved in file content." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir) - (url "https://stream.example.com/radio?format=mp3&quality=320&token=abc123")) - (cj/music-create-radio-station "Test Radio" url) - (let ((content (with-temp-buffer - (insert-file-contents - (expand-file-name "Test_Radio_Radio.m3u" test-dir)) - (buffer-string)))) - (should (string-match-p (regexp-quote url) content)))) - (test-music-config-create-radio-station-teardown)))) - -(ert-deftest test-music-config-create-radio-station-boundary-overwrite-confirmed () - "Overwriting existing file when user confirms succeeds." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - ;; Create initial file - (cj/music-create-radio-station "MyRadio" "http://old.url/stream") - (let ((file (expand-file-name "MyRadio_Radio.m3u" test-dir))) - (should (file-exists-p file)) - ;; Overwrite with user confirming - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) - (cj/music-create-radio-station "MyRadio" "http://new.url/stream")) - ;; File should now contain new URL - (let ((content (with-temp-buffer - (insert-file-contents file) - (buffer-string)))) - (should (string-match-p "http://new.url/stream" content)) - (should-not (string-match-p "http://old.url/stream" content))))) - (test-music-config-create-radio-station-teardown)))) +(ert-deftest test-music-config-create-radio-station-boundary-unicode-name () + "Boundary: a unicode name is kept verbatim on the track (no filename munging)." + (test-music-create-radio--with-env + (cj/music-create-radio-station "Café Del Mar ☕" "https://cafe.example/stream") + (should (equal (emms-track-get (car (test-music-create-radio--queued-tracks)) + 'info-title) + "Café Del Mar ☕")))) + +;;; Keymap + +(ert-deftest test-music-config-radio-map-prefix-mirrors-playlist-keys () + "Normal: C-; m r is a radio prefix whose n/t/m mirror the playlist buffer." + (let ((map (lookup-key cj/music-map "r"))) + (should (keymapp map)) + (should (eq (lookup-key map "n") 'cj/music-radio-search-by-name)) + (should (eq (lookup-key map "t") 'cj/music-radio-search-by-tag)) + (should (eq (lookup-key map "m") 'cj/music-create-radio-station)))) + +(ert-deftest test-music-config-menu-map-lowercase-keys () + "Normal: the menu's former uppercase keys live on lowercase homes, and the +playlist buffer saves on 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 "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 (ert-deftest test-music-config-create-radio-station-error-empty-name-signals-user-error () - "Empty station name signals user-error." - (should-error (cj/music-create-radio-station "" "http://example.com/stream") - :type 'user-error)) + "Error: empty name signals user-error." + (should-error (cj/music-create-radio-station "" "https://x") :type 'user-error)) (ert-deftest test-music-config-create-radio-station-error-empty-url-signals-user-error () - "Empty URL signals user-error." - (should-error (cj/music-create-radio-station "Test Radio" "") - :type 'user-error)) - -(ert-deftest test-music-config-create-radio-station-error-overwrite-declined-signals-user-error () - "Declining overwrite signals user-error." - (let ((test-dir (test-music-config-create-radio-station-setup))) - (unwind-protect - (let ((cj/music-m3u-root test-dir)) - ;; Create initial file - (cj/music-create-radio-station "MyRadio" "http://old.url/stream") - ;; Decline overwrite - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) nil))) - (should-error (cj/music-create-radio-station "MyRadio" "http://new.url/stream") - :type 'user-error))) - (test-music-config-create-radio-station-teardown)))) + "Error: empty URL signals user-error." + (should-error (cj/music-create-radio-station "NPR" "") :type 'user-error)) (provide 'test-music-config-create-radio-station) ;;; test-music-config-create-radio-station.el ends here diff --git a/tests/test-music-config-helpers-untested.el b/tests/test-music-config-helpers-untested.el index bfdb2634..87aa210c 100644 --- a/tests/test-music-config-helpers-untested.el +++ b/tests/test-music-config-helpers-untested.el @@ -154,17 +154,18 @@ test prelude inserts filler with `inhibit-read-only' bound." ;;; ---------- cj/music-add-directory-recursive ---------- (ert-deftest test-mc-add-directory-recursive-normal-calls-emms () - "Normal: with an existing directory, the recursive add reaches emms." + "Normal: with an existing directory, the recursive add reaches emms with +each music file individually (the filtered walk, not the raw tree)." (test-mc-untested--setup) (unwind-protect (let* ((dir cj/test-base-dir) - (called-with nil)) - (cl-letf (((symbol-function 'emms-add-directory-tree) - (lambda (d) (setq called-with d))) + (added nil)) + (write-region "" nil (expand-file-name "one.mp3" dir)) + (cl-letf (((symbol-function 'emms-add-file) + (lambda (f) (push f added))) ((symbol-function 'message) #'ignore)) (cj/music-add-directory-recursive dir)) - (should (equal (file-name-as-directory called-with) - (file-name-as-directory dir)))) + (should (member "one.mp3" (mapcar #'file-name-nondirectory added)))) (test-mc-untested--teardown))) (ert-deftest test-mc-add-directory-recursive-error-not-a-directory () diff --git a/tests/test-music-config-more-commands.el b/tests/test-music-config-more-commands.el index c351c1f1..530aa379 100644 --- a/tests/test-music-config-more-commands.el +++ b/tests/test-music-config-more-commands.el @@ -9,7 +9,9 @@ ;; cj/music-playlist-edit ;; cj/music-playlist-toggle ;; cj/music-playlist-show -;; cj/music-create-radio-station +;; +;; cj/music-create-radio-station lives in +;; test-music-config-create-radio-station.el. ;;; Code: @@ -17,12 +19,21 @@ (require 'cl-lib) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(let ((emms-dir (car (file-expand-wildcards + (expand-file-name "elpa/emms-*" user-emacs-directory))))) + (when emms-dir (add-to-list 'load-path emms-dir))) + +(require 'emms) (require 'music-config) ;; Top-level defvars so let-binds reach the dynamic var under lexical ;; scope. (defvar cj/music-playlist-file nil) -(defvar emms-source-playlist-ask-before-overwrite t) ;;; cj/music-playlist-load @@ -56,28 +67,87 @@ ;;; cj/music-playlist-save -(ert-deftest test-music-playlist-save-writes-fresh-name () - "Normal: save with a fresh name writes via emms-playlist-save." - (let* ((tmp (file-name-as-directory (make-temp-file "cj-music-save-" t))) - (cj/music-m3u-root tmp) - saved-args msg) - (unwind-protect - (cl-letf (((symbol-function 'cj/music--get-m3u-basenames) - (lambda () nil)) - ((symbol-function 'completing-read) - (lambda (&rest _) "fresh")) - ((symbol-function 'cj/music--ensure-playlist-buffer) - (lambda () (current-buffer))) - ((symbol-function 'emms-playlist-save) - (lambda (fmt path) (setq saved-args (list fmt path)))) - ((symbol-function 'cj/music--sync-playlist-file) #'ignore) - ((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/music-playlist-save)) - (delete-directory tmp t)) - (should (equal (car saved-args) 'm3u)) - (should (string-match-p "fresh\\.m3u\\'" (cadr saved-args))) - (should (string-match-p "Saved playlist" msg)))) +(defmacro test-music-save--with-env (&rest body) + "Run BODY with a fresh playlist buffer and temp save directories. +Binds TMP-M3U and TMP-RADIO (both cleaned up) and captures completing-read's +INITIAL argument in CR-INITIAL." + `(let* ((cj/music-playlist-buffer-name + (generate-new-buffer-name "*test-save*")) + (tmp-m3u (file-name-as-directory (make-temp-file "cj-save-m3u-" t))) + (tmp-radio (file-name-as-directory (make-temp-file "cj-save-radio-" t))) + (cj/music-m3u-root tmp-m3u) + (cj/music-radio-save-dir tmp-radio) + (cr-initial 'unset)) + (ignore cr-initial) + (unwind-protect + (cl-letf (((symbol-function 'message) #'ignore) + ((symbol-function 'completing-read) + (lambda (_prompt _coll &optional _pred _req initial _hist def &rest _) + (setq cr-initial initial) + (or initial def "fallback")))) + ,@body) + (when (get-buffer cj/music-playlist-buffer-name) + (kill-buffer cj/music-playlist-buffer-name)) + (delete-directory tmp-m3u t) + (delete-directory tmp-radio t)))) + +(defun test-music-save--queue (tracks) + "Put TRACKS into the (fresh) test playlist buffer." + (with-current-buffer (cj/music--ensure-playlist-buffer) + (save-excursion + (goto-char (point-max)) + (dolist (tr tracks) + (emms-playlist-insert-track tr))))) + +(ert-deftest test-music-playlist-save-station-queue-prefills-and-targets-radio-dir () + "Normal: an all-stream queue pre-fills the station name and saves into the +radio dir with the station metadata written." + (test-music-save--with-env + (let ((tr (emms-track 'url "https://gs.example/stream"))) + (emms-track-set tr 'info-title "Groove Salad") + (emms-track-set tr 'radio-uuid "uuid-gs") + (test-music-save--queue (list tr))) + (cj/music-playlist-save) + (should (equal cr-initial "Groove Salad")) + (let ((file (expand-file-name "Groove Salad.m3u" tmp-radio))) + (should (file-exists-p file)) + (with-temp-buffer + (insert-file-contents file) + (let ((text (buffer-string))) + (should (string-match-p "^#EXTINF:-1,Groove Salad$" text)) + (should (string-match-p "^#RADIOBROWSERUUID:uuid-gs$" text)) + (should (string-match-p "^https://gs\\.example/stream$" text))))) + (should-not (directory-files tmp-m3u nil "\\.m3u\\'")))) + +(ert-deftest test-music-playlist-save-file-queue-targets-m3u-root-no-prefill () + "Normal: a file queue saves into the music root with no station pre-fill." + (test-music-save--with-env + (test-music-save--queue (list (emms-track 'file "/music/a.flac"))) + (cj/music-playlist-save) + (should-not cr-initial) + (should (= (length (directory-files tmp-m3u nil "\\.m3u\\'")) 1)) + (should-not (directory-files tmp-radio nil "\\.m3u\\'")))) + +(ert-deftest test-music-playlist-save-associated-file-name-wins-over-station () + "Normal: a queue with an associated playlist file defaults to that name, +even when it contains stations." + (test-music-save--with-env + (let ((tr (emms-track 'url "https://gs.example/stream"))) + (emms-track-set tr 'info-title "Groove Salad") + (test-music-save--queue (list tr))) + (with-current-buffer (cj/music--ensure-playlist-buffer) + (setq cj/music-playlist-file (expand-file-name "morning.m3u" tmp-radio))) + (cj/music-playlist-save) + (should-not cr-initial) + (should (file-exists-p (expand-file-name "morning.m3u" tmp-radio))))) + +(ert-deftest test-music-playlist-save-error-empty-name () + "Error: an empty name at the prompt signals user-error, not a hidden .m3u." + (test-music-save--with-env + (test-music-save--queue (list (emms-track 'url "https://x.example/s"))) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) ""))) + (should-error (cj/music-playlist-save) :type 'user-error)) + (should-not (directory-files tmp-radio nil "m3u")))) ;;; cj/music-playlist-edit @@ -138,36 +208,5 @@ (should (eq switched buf)) (should msg))) -;;; cj/music-create-radio-station - -(ert-deftest test-music-create-radio-station-writes-m3u () - "Normal: with name+url, an EXTM3U-style file is written into music-m3u-root." - (let* ((tmp (file-name-as-directory (make-temp-file "cj-music-radio-" t))) - (cj/music-m3u-root tmp) - msg) - (unwind-protect - (progn - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq msg (apply #'format fmt args))))) - (cj/music-create-radio-station "NPR" "https://example.test/stream")) - (let ((file (expand-file-name "NPR_Radio.m3u" tmp))) - (should (file-exists-p file)) - (with-temp-buffer - (insert-file-contents file) - (let ((text (buffer-string))) - (should (string-match-p "#EXTM3U" text)) - (should (string-match-p "NPR" text)) - (should (string-match-p "https://example.test/stream" text)))))) - (delete-directory tmp t)) - (should (string-match-p "Created radio station" msg)))) - -(ert-deftest test-music-create-radio-station-rejects-empty-name () - "Error: an empty name is rejected with user-error." - (should-error (cj/music-create-radio-station "" "https://x") :type 'user-error)) - -(ert-deftest test-music-create-radio-station-rejects-empty-url () - "Error: an empty URL is rejected with user-error." - (should-error (cj/music-create-radio-station "NPR" "") :type 'user-error)) - (provide 'test-music-config-more-commands) ;;; test-music-config-more-commands.el ends here diff --git a/tests/test-nov-reading--config-defaults.el b/tests/test-nov-reading--config-defaults.el 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-commands.el b/tests/test-org-agenda-config-commands.el index 76407439..139bf90f 100644 --- a/tests/test-org-agenda-config-commands.el +++ b/tests/test-org-agenda-config-commands.el @@ -176,5 +176,89 @@ large), so the standalone OVERDUE section was redundant." (should (string-match-p "<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} 09:00>" text))))) +(ert-deftest test-org-agenda-add-timestamp-preserves-point-and-following-line () + "Normal: the stamp lands between the entry and the next line, point unmoved. +The docstring promises the event appears \"underneath the line-at-point\", +so neither the entry nor whatever follows it may be disturbed." + (with-temp-buffer + (insert "* First\n* Second") + (goto-char (point-min)) + (let ((start (progn (org-end-of-line) (point)))) + (goto-char (point-min)) + (cj/add-timestamp-to-org-entry "09:00") + ;; Point is left at the end of the entry it stamped. + (should (= (point) start))) + (let ((lines (split-string (buffer-string) "\n"))) + (should (equal (nth 0 lines) "* First")) + (should (string-match-p "\\`<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} 09:00>\\'" + (nth 1 lines))) + (should (equal (nth 2 lines) "* Second"))))) + +(ert-deftest test-org-agenda-add-timestamp-empty-time-string () + "Boundary: an empty time yields a bare date stamp with a trailing space. +Characterizes current behavior -- the separator space is unconditional, so +an empty S produces `<DATE >' rather than `<DATE>'. Harmless in an agenda +\(org reads the date\), and pinned here so a future format change is a +deliberate one." + (with-temp-buffer + (insert "* Heading here") + (goto-char (point-min)) + (cj/add-timestamp-to-org-entry "") + (should (string-match-p "<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} >" + (buffer-string))))) + +(ert-deftest test-org-agenda-add-timestamp-unicode-time-string () + "Boundary: non-ASCII in S survives into the stamp uncorrupted." + (with-temp-buffer + (insert "* Heading here") + (goto-char (point-min)) + (cj/add-timestamp-to-org-entry "09:00 café ☕") + (should (string-match-p "09:00 café ☕>" (buffer-string))))) + +(ert-deftest test-org-agenda-add-timestamp-empty-buffer () + "Boundary: an empty buffer still gets a stamp rather than signalling. +`org-end-of-line' and `open-line' both no-op safely at point-min." + (with-temp-buffer + (cj/add-timestamp-to-org-entry "09:00") + (should (string-match-p "<[0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [A-Za-z]\\{3\\} 09:00>" + (buffer-string))))) + +(ert-deftest test-org-agenda-add-timestamp-read-only-buffer-signals () + "Error: a read-only buffer signals rather than silently dropping the stamp." + (with-temp-buffer + (insert "* Heading") + (goto-char (point-min)) + (setq buffer-read-only t) + (should-error (cj/add-timestamp-to-org-entry "09:00") :type 'buffer-read-only))) + +(defconst test-org-agenda--timeformat-special-at-load + (special-variable-p 'cj/timeformat) + "Whether `cj/timeformat' was special immediately after loading the module. +Captured here at load, before any test body runs, because the fact under +test is destroyed by observing it late: calling +`cj/add-timestamp-to-org-entry' once would execute a `defvar' nested in the +defun and make the symbol special retroactively. ERT runs tests +alphabetically, so an in-test `special-variable-p' check passes on the +strength of whichever test ran first -- green in a full-file run, red in +isolation. Snapshotting at load makes the guard order-independent.") + +(ert-deftest test-org-agenda-timeformat-is-a-top-level-special-variable () + "Normal: `cj/timeformat' is special and bound at load, not first call. +It used to be `defvar'd inside `cj/add-timestamp-to-org-entry', so it was +unbound until the command ran once and a `let' around the call bound it +lexically instead of dynamically. Pinning both halves of the fix: the +symbol is special at load time, and rebinding it actually reaches the +command." + (should test-org-agenda--timeformat-special-at-load) + (should (equal (default-value 'cj/timeformat) "%Y-%m-%d %a")) + ;; The dynamic binding must reach the insertion. + (with-temp-buffer + (insert "* Heading") + (goto-char (point-min)) + (let ((cj/timeformat "%Y")) + (cj/add-timestamp-to-org-entry "09:00")) + (should (string-match-p "\\`<[0-9]\\{4\\} 09:00>\\'" + (nth 1 (split-string (buffer-string) "\n")))))) + (provide 'test-org-agenda-config-commands) ;;; test-org-agenda-config-commands.el ends here diff --git a/tests/test-org-agenda-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-capture-config--neutralize.el b/tests/test-org-capture-config--neutralize.el new file mode 100644 index 00000000..4a03830a --- /dev/null +++ b/tests/test-org-capture-config--neutralize.el @@ -0,0 +1,136 @@ +;;; test-org-capture-config--neutralize.el --- Popup neutralize-guard tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the "org-capture" popup neutralize guards. The popup frame opens +;; showing the daemon's last buffer; if a capture aborts before its UI paints, +;; the popup lingers on that buffer, and a live eat/vterm terminal shown there +;; clamps the real frame to the popup's rows. The guards repoint every +;; non-capture-UI window of the popup at *scratch*: one fires on frame creation +;; (after-make-frame-functions), one on any buffer change +;; (window-buffer-change-functions). +;; +;; The tests drive the real batch frame (renamed to "org-capture" and restored +;; in cleanup, the same idiom as the popup-window integration test) rather than +;; mocking frame primitives. `window-buffer-change-functions' only runs during +;; redisplay, so the module's own hook cannot fire mid-test in batch. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'org) +(require 'org-capture) +(require 'user-constants) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-capture-config) + +(defmacro test-neutralize--with-popup-frame (buffer-name &rest body) + "Run BODY with the batch frame named \"org-capture\" showing BUFFER-NAME. +The frame name reverts to auto-naming and the test buffer is killed +afterward. BODY sees the buffer bound to `buf'." + (declare (indent 1)) + `(let ((buf (get-buffer-create ,buffer-name))) + (unwind-protect + (progn + (set-frame-parameter nil 'name "org-capture") + (delete-other-windows) + (set-window-buffer (selected-window) buf) + ,@body) + ;; Restore to nil, not the saved name: the batch frame's auto name is + ;; "F1", and Emacs refuses to set F<num>-shaped names explicitly. + ;; nil reverts to auto-naming (same idiom as the popup-window test). + (set-frame-parameter nil 'name nil) + (when (buffer-live-p buf) (kill-buffer buf))))) + +;;; cj/org-capture--neutralize-frame + +(ert-deftest test-org-capture-config-neutralize-frame-evicts-plain-buffer () + "Normal: a non-capture-UI buffer in the popup frame is repointed to *scratch*." + (test-neutralize--with-popup-frame "neutralize-plain.org" + (cj/org-capture--neutralize-frame (selected-frame)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +(ert-deftest test-org-capture-config-neutralize-frame-spares-capture-buffer () + "Normal: a CAPTURE-* buffer is capture UI and stays put." + (test-neutralize--with-popup-frame "CAPTURE-neutralize.org" + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) buf)))) + +(ert-deftest test-org-capture-config-neutralize-frame-spares-select-menu () + "Normal: the *Org Select* template menu is capture UI and stays put." + (test-neutralize--with-popup-frame "*Org Select*" + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) buf)))) + +(ert-deftest test-org-capture-config-neutralize-frame-scratch-untouched () + "Boundary: a window already on *scratch* is left alone (idempotent)." + (let ((scratch (get-buffer-create "*scratch*"))) + (unwind-protect + (progn + (set-frame-parameter nil 'name "org-capture") + (delete-other-windows) + (set-window-buffer (selected-window) scratch) + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) scratch)) + ;; Second pass is also a no-op. + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) scratch))) + (set-frame-parameter nil 'name nil)))) + +(ert-deftest test-org-capture-config-neutralize-frame-other-frame-untouched () + "Boundary: a frame not named \"org-capture\" is never neutralized." + (let ((buf (get-buffer-create "neutralize-other-frame.org"))) + (unwind-protect + (progn + (set-frame-parameter nil 'name "some-other-frame") + (delete-other-windows) + (set-window-buffer (selected-window) buf) + (cj/org-capture--neutralize-frame (selected-frame)) + (should (eq (window-buffer (selected-window)) buf))) + (set-frame-parameter nil 'name nil) + (when (buffer-live-p buf) (kill-buffer buf))))) + +(ert-deftest test-org-capture-config-neutralize-frame-dead-input-no-error () + "Error: nil and non-frame inputs are ignored without raising." + (should-not (cj/org-capture--neutralize-frame nil)) + (should-not (cj/org-capture--neutralize-frame 'not-a-frame))) + +;;; cj/org-capture--neutralize-new-frame (Guard 1 wrapper) + +(ert-deftest test-org-capture-config-neutralize-new-frame-delegates () + "Normal: the frame-creation wrapper neutralizes the popup frame." + (test-neutralize--with-popup-frame "neutralize-new-frame.org" + (cj/org-capture--neutralize-new-frame (selected-frame)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +;;; cj/org-capture--neutralize-on-buffer-change (Guard 2 wrapper) + +(ert-deftest test-org-capture-config-neutralize-on-buffer-change-window-arg () + "Normal: a window argument resolves to its frame and neutralizes it. +`window-buffer-change-functions' passes a window when buffer-local." + (test-neutralize--with-popup-frame "neutralize-window-arg.org" + (cj/org-capture--neutralize-on-buffer-change (selected-window)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +(ert-deftest test-org-capture-config-neutralize-on-buffer-change-frame-arg () + "Normal: a frame argument passes straight through. +`window-buffer-change-functions' passes a frame when global." + (test-neutralize--with-popup-frame "neutralize-frame-arg.org" + (cj/org-capture--neutralize-on-buffer-change (selected-frame)) + (should (equal (buffer-name (window-buffer (selected-window))) + "*scratch*")))) + +;;; Hook wiring + +(ert-deftest test-org-capture-config-neutralize-hooks-registered () + "Normal: both guards are installed on their hooks at module load." + (should (memq #'cj/org-capture--neutralize-new-frame + after-make-frame-functions)) + (should (memq #'cj/org-capture--neutralize-on-buffer-change + window-buffer-change-functions))) + +(provide 'test-org-capture-config--neutralize) +;;; test-org-capture-config--neutralize.el ends here diff --git a/tests/test-org-contacts-config-find.el b/tests/test-org-contacts-config-find.el new file mode 100644 index 00000000..60a5e713 --- /dev/null +++ b/tests/test-org-contacts-config-find.el @@ -0,0 +1,72 @@ +;;; test-org-contacts-config-find.el --- Tests for cj/org-contacts-find -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/org-contacts-find collects contact headings (name, position, and the +;; EMAIL/PHONE annotation) before prompting, then jumps to the selected +;; heading's stored position. These tests pin the collector helper and a +;; command-level smoke test: the jump must land on the heading, never on a +;; body line that merely mentions the name. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'org) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-contacts-config) + +;;; cj/--org-contacts-collect + +(ert-deftest test-org-contacts-collect-returns-name-position-info () + "Normal: collector returns heading name, heading position, and EMAIL/PHONE." + (with-temp-buffer + (org-mode) + (insert "* Alice\n:PROPERTIES:\n:EMAIL: alice@example.com\n:END:\n" + "some body text mentioning Bob\n" + "* Bob\n:PROPERTIES:\n:PHONE: 555-1234\n:END:\n") + (let* ((alist (cj/--org-contacts-collect (current-buffer))) + (alice (assoc "Alice" alist)) + (bob (assoc "Bob" alist))) + (should (equal (length alist) 2)) + (should (equal (nth 2 alice) "alice@example.com")) + (should (equal (nth 2 bob) "555-1234")) + ;; positions land on the headings, not the body line that mentions Bob + (should (save-excursion (goto-char (nth 1 alice)) (looking-at "\\* Alice"))) + (should (save-excursion (goto-char (nth 1 bob)) (looking-at "\\* Bob")))))) + +(ert-deftest test-org-contacts-collect-empty-buffer-returns-nil () + "Boundary: a buffer with no headings yields an empty alist." + (with-temp-buffer + (org-mode) + (should (null (cj/--org-contacts-collect (current-buffer)))))) + +(ert-deftest test-org-contacts-collect-heading-without-props-has-nil-info () + "Error: a heading with no EMAIL or PHONE yields nil info." + (with-temp-buffer + (org-mode) + (insert "* Carol\n") + (let ((alist (cj/--org-contacts-collect (current-buffer)))) + (should (equal (nth 2 (assoc "Carol" alist)) nil))))) + +;;; cj/org-contacts-find + +(ert-deftest test-org-contacts-find-jumps-to-heading-not-body () + "Normal: selecting a contact jumps to its heading, not a body mention." + (let ((contacts-file (make-temp-file "org-contacts-test-" nil ".org"))) + (unwind-protect + (progn + (with-temp-file contacts-file + (insert "* Alice\n:PROPERTIES:\n:EMAIL: alice@example.com\n:END:\n" + "note: call Bob about Alice\n" + "* Bob\n:PROPERTIES:\n:PHONE: 555-1234\n:END:\n")) + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest _) "Bob")) + ((symbol-function 'org-fold-show-entry) #'ignore) + ((symbol-function 'org-reveal) #'ignore)) + (cj/org-contacts-find) + (should (looking-at "\\* Bob")))) + (delete-file contacts-file)))) + +(provide 'test-org-contacts-config-find) +;;; test-org-contacts-config-find.el ends here diff --git a/tests/test-org-drill-config-source.el b/tests/test-org-drill-config-source.el new file mode 100644 index 00000000..ccda99ef --- /dev/null +++ b/tests/test-org-drill-config-source.el @@ -0,0 +1,31 @@ +;;; test-org-drill-config-source.el --- Tests for org-drill source selection -*- lexical-binding: t; -*- + +;;; Commentary: +;; cj/--org-drill-source-keywords decides how use-package obtains org-drill: +;; a local dev checkout via :load-path when it exists, otherwise the upstream +;; repo via :vc. Without this, a machine lacking the checkout hits :demand t +;; against a nonexistent :load-path and drill fails to load entirely. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-drill-config) + +(ert-deftest test-org-drill-source-keywords-uses-load-path-when-checkout-exists () + "Normal: an existing checkout directory selects :load-path." + (let ((dir (make-temp-file "org-drill-checkout-" t))) + (unwind-protect + (should (equal (cj/--org-drill-source-keywords dir) + (list :load-path dir))) + (delete-directory dir t)))) + +(ert-deftest test-org-drill-source-keywords-falls-back-to-vc-when-absent () + "Error: a missing checkout falls back to a :vc install spec." + (let ((kws (cj/--org-drill-source-keywords "/nonexistent/org-drill-xyz"))) + (should (eq (car kws) :vc)) + (should (plist-get (nth 1 kws) :url)))) + +(provide 'test-org-drill-config-source) +;;; test-org-drill-config-source.el ends here diff --git a/tests/test-org-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-reveal-config-keymap.el b/tests/test-org-reveal-config-keymap.el new file mode 100644 index 00000000..17a21b19 --- /dev/null +++ b/tests/test-org-reveal-config-keymap.el @@ -0,0 +1,38 @@ +;;; test-org-reveal-config-keymap.el --- Tests for org-reveal-config prefix keymap -*- lexical-binding: t; -*- + +;;; Commentary: +;; The presentation commands are reached through `cj/reveal-map', a prefix +;; keymap registered under "C-; p" via `cj/register-prefix-map'. These +;; tests pin that structure so the module can't silently regress to raw +;; `global-set-key' calls (which carry a hidden load-order dependency on +;; keybindings.el establishing "C-;" as a prefix first). + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'keybindings) +(require 'org-reveal-config) + +(ert-deftest test-org-reveal-config-reveal-map-is-a-keymap () + "Normal: `cj/reveal-map' is a keymap." + (should (keymapp cj/reveal-map))) + +(ert-deftest test-org-reveal-config-reveal-map-bindings () + "Normal: each presentation command is reachable under `cj/reveal-map'." + (dolist (pair '(("SPC" . cj/reveal-present) + ("e" . cj/reveal-export) + ("p" . cj/reveal-preview-start) + ("s" . cj/reveal-preview-stop) + ("h" . cj/reveal-insert-header) + ("H" . cj/reveal-remove-headers) + ("n" . cj/reveal-new))) + (should (eq (keymap-lookup cj/reveal-map (car pair)) (cdr pair))))) + +(ert-deftest test-org-reveal-config-reveal-map-registered-under-p () + "Normal: `cj/reveal-map' is registered under \"p\" in `cj/custom-keymap'." + (should (eq (keymap-lookup cj/custom-keymap "p") cj/reveal-map))) + +(provide 'test-org-reveal-config-keymap) +;;; test-org-reveal-config-keymap.el ends here diff --git a/tests/test-org-roam-config-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-org-roam-config-tag-and-find.el b/tests/test-org-roam-config-tag-and-find.el index f98d8af0..97a7a683 100644 --- a/tests/test-org-roam-config-tag-and-find.el +++ b/tests/test-org-roam-config-tag-and-find.el @@ -147,6 +147,17 @@ ;; The 4th arg is the subdir (should (equal (nth 3 args) "recipes/")))) +(ert-deftest test-org-roam-find-node-project-delegates-to-find-node () + "Normal: `find-node-project' uses Project tag, 'p' key, project.org template." + (let ((args nil)) + (cl-letf (((symbol-function 'cj/org-roam-find-node) + (lambda (&rest a) (setq args a)))) + (cj/org-roam-find-node-project)) + (should (equal (car args) "Project")) + (should (equal (cadr args) "p")) + ;; The 3rd arg is the template file, under the canonical roam-dir/templates/. + (should (string-suffix-p "templates/project.org" (nth 2 args))))) + ;;; cj/org-roam-node-insert-immediate (ert-deftest test-org-roam-node-insert-immediate-rebinds-templates-and-calls-insert () diff --git a/tests/test-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-general-lsp.el b/tests/test-prog-general-lsp.el new file mode 100644 index 00000000..e61e9a17 --- /dev/null +++ b/tests/test-prog-general-lsp.el @@ -0,0 +1,148 @@ +;;; test-prog-general-lsp.el --- LSP config + helper tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the LSP configuration in prog-general.el, the single owner of +;; generic LSP policy (prog-lsp.el was folded in and removed 2026-07-10). +;; +;; Two layers: +;; - Load-time invariants that hold the moment the config loads, before any +;; server starts: lsp-enable-remote stays nil (so TRAMP files don't auto-start +;; a slow LSP), and no mode accrues a duplicate lsp-deferred entry. +;; - The pure helpers cj/lsp--add-file-watch-ignored-extras and +;; cj/lsp--remove-eldoc-provider-global, exercised directly with Normal / +;; Boundary / Error cases. +;; +;; The quiet-UI :config defaults (snippet off, symbol highlighting off, +;; idle-delay 0.5, ...) are deferred to lsp-mode's own load (see the make-test +;; no-package-initialize note in CLAUDE.md), so they aren't asserted here; the +;; daemon verifies them. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'use-package) + +;; Declare lsp-mode's defcustom / eldoc's hook as special so `let' binds them +;; dynamically. Real definitions load only when lsp-mode / eldoc activate; in +;; the test environment these provide the value cells the helpers read through. +(defvar lsp-file-watch-ignored-directories nil) +(defvar eldoc-documentation-functions nil) + +(defun lsp-eldoc-function (&rest _args) + "Stub lsp-mode Eldoc function for tests.") + +(require 'prog-general) + +;;; Load-time invariants + +(ert-deftest test-prog-general-lsp-enable-remote-nil () + "Normal: lsp-enable-remote is nil so LSP never auto-starts on TRAMP files." + (should (boundp 'lsp-enable-remote)) + (should (null lsp-enable-remote))) + +(ert-deftest test-prog-general-lsp-no-duplicate-mode-hook () + "Boundary: a mode never holds more than one lsp-deferred entry. +The per-language modules add lsp-deferred to their own mode hooks; add-hook +dedups identical symbols, and this pins that invariant so a future non-symbol +\(lambda) addition that breaks it gets caught." + (dolist (hook '(c-mode-hook python-mode-hook go-ts-mode-hook)) + (when (boundp hook) + (should (>= 1 (cl-count 'lsp-deferred (symbol-value hook))))))) + +;;; File-watch ignore helper — Normal + +(ert-deftest test-prog-general-lsp-file-watch-adds-all-patterns () + "Normal: every entry from `cj/lsp-file-watch-ignored-extras' lands in the list." + (let ((lsp-file-watch-ignored-directories nil)) + (cj/lsp--add-file-watch-ignored-extras) + (should (= (length lsp-file-watch-ignored-directories) + (length cj/lsp-file-watch-ignored-extras))) + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (member pattern lsp-file-watch-ignored-directories))))) + +(ert-deftest test-prog-general-lsp-file-watch-extends-not-replaces () + "Normal: pre-existing entries (lsp-mode defaults) are preserved." + (let ((lsp-file-watch-ignored-directories + '("[/\\\\]\\.git\\'" "[/\\\\]\\.svn\\'" "[/\\\\]\\.idea\\'"))) + (cj/lsp--add-file-watch-ignored-extras) + (should (member "[/\\\\]\\.git\\'" lsp-file-watch-ignored-directories)) + (should (member "[/\\\\]\\.svn\\'" lsp-file-watch-ignored-directories)) + (should (member "[/\\\\]\\.idea\\'" lsp-file-watch-ignored-directories)) + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (member pattern lsp-file-watch-ignored-directories))))) + +(ert-deftest test-prog-general-lsp-file-watch-key-patterns-present () + "Normal: specific expected directory names appear in the constant." + (dolist (name '("node_modules" "target" "__pycache__" ".venv" "venv" + "dist" "coverage" "test-results" "playwright-report" + ".terraform" ".ruff_cache" ".pytest_cache" ".mypy_cache")) + (should (cl-some (lambda (p) (string-match-p (regexp-quote name) p)) + cj/lsp-file-watch-ignored-extras)))) + +;;; File-watch ignore helper — Boundary + +(ert-deftest test-prog-general-lsp-file-watch-idempotent () + "Boundary: calling twice leaves each pattern present exactly once." + (let ((lsp-file-watch-ignored-directories nil)) + (cj/lsp--add-file-watch-ignored-extras) + (cj/lsp--add-file-watch-ignored-extras) + (should (= (length lsp-file-watch-ignored-directories) + (length cj/lsp-file-watch-ignored-extras))) + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (= 1 (cl-count pattern lsp-file-watch-ignored-directories + :test #'equal)))))) + +(ert-deftest test-prog-general-lsp-file-watch-all-patterns-non-empty () + "Boundary: every pattern is a non-empty string." + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (should (stringp pattern)) + (should (not (string-empty-p pattern))))) + +(ert-deftest test-prog-general-lsp-file-watch-all-patterns-valid-regex () + "Boundary: every pattern compiles as a valid Emacs regex." + (dolist (pattern cj/lsp-file-watch-ignored-extras) + (condition-case err + ;; string-match-p compiles the regex; invalid syntax raises invalid-regexp. + (string-match-p pattern "/some/sample/path") + (invalid-regexp + (ert-fail (format "Invalid regex %S: %s" + pattern (error-message-string err))))))) + +;;; File-watch ignore helper — Error + +(ert-deftest test-prog-general-lsp-file-watch-non-list-target () + "Error: non-list target value triggers `add-to-list' wrong-type-argument." + (let ((lsp-file-watch-ignored-directories "not-a-list")) + (should-error (cj/lsp--add-file-watch-ignored-extras) + :type 'wrong-type-argument))) + +;;; Eldoc provider helper + +(ert-deftest test-prog-general-lsp-eldoc-provider-removed-globally () + "Normal: remove lsp-mode's Eldoc provider from the global hook value. +The per-buffer removal this replaced raced lsp-mode's own buffer-local hook +population; removing globally before any LSP buffer attaches makes the absence +stick for every subsequent lsp-managed buffer." + (let ((eldoc-documentation-functions + (list #'lsp-eldoc-function 'eldoc-documentation-default))) + (cj/lsp--remove-eldoc-provider-global) + (should-not (memq #'lsp-eldoc-function eldoc-documentation-functions)) + (should (memq 'eldoc-documentation-default eldoc-documentation-functions)))) + +(ert-deftest test-prog-general-lsp-eldoc-provider-removal-idempotent () + "Boundary: re-running the removal after the provider is gone is a no-op." + (let ((eldoc-documentation-functions '(eldoc-documentation-default))) + (cj/lsp--remove-eldoc-provider-global) + (cj/lsp--remove-eldoc-provider-global) + (should (equal eldoc-documentation-functions + '(eldoc-documentation-default))))) + +(ert-deftest test-prog-general-lsp-no-obsolete-eldoc-hook-reference () + "Regression: prog-general should not reference obsolete `lsp-eldoc-hook'." + (with-temp-buffer + (insert-file-contents (expand-file-name "modules/prog-general.el" user-emacs-directory)) + (should-not (re-search-forward "\\_<lsp-eldoc-hook\\_>" nil t)))) + +(provide 'test-prog-general-lsp) +;;; test-prog-general-lsp.el ends here diff --git a/tests/test-prog-go--classic-mode-hooks.el b/tests/test-prog-go--classic-mode-hooks.el new file mode 100644 index 00000000..a9defe2e --- /dev/null +++ b/tests/test-prog-go--classic-mode-hooks.el @@ -0,0 +1,46 @@ +;;; test-prog-go--classic-mode-hooks.el --- Classic go-mode hooks + gopls warn -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found the Go setup hooks attached to go-ts-mode +;; only, so a fallback to classic go-mode silently lost indent, keys, +;; and LSP. It also flagged gopls for the load-time missing-tool +;; warning pyright/prettier already have; that warn is only honest if +;; ~/go/bin is on `exec-path' at load time (it used to join only in +;; go-mode's deferred :config, so gopls installed there read as +;; missing). + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-go) + +(ert-deftest test-prog-go-hooks-cover-classic-go-mode () + "Normal: classic go-mode runs the same setup + keybindings as go-ts-mode." + (dolist (hook '(go-mode-hook go-ts-mode-hook)) + (should (memq #'cj/go-setup (symbol-value hook))) + (should (memq #'cj/go-mode-keybindings (symbol-value hook))))) + +(ert-deftest test-prog-go-bin-path-on-exec-path-at-load () + "Normal: ~/go/bin joins `exec-path' at module load, not first go buffer. +The load-time gopls warn resolves through `exec-path'; registering the +Go bin directory only in go-mode's deferred :config would make gopls +installed there warn as missing on every start." + (should (member go-bin-path exec-path))) + +(ert-deftest test-prog-go-warns-when-gopls-missing () + "Error: loading the module without gopls on PATH warns about gopls." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-go.el" user-emacs-directory) nil t)) + (should (cl-some (lambda (m) (string-match-p "gopls" m)) warned)))) + +(provide 'test-prog-go--classic-mode-hooks) +;;; test-prog-go--classic-mode-hooks.el ends here diff --git a/tests/test-prog-lsp--add-file-watch-ignored-extras.el b/tests/test-prog-lsp--add-file-watch-ignored-extras.el deleted file mode 100644 index 9b71cab8..00000000 --- a/tests/test-prog-lsp--add-file-watch-ignored-extras.el +++ /dev/null @@ -1,116 +0,0 @@ -;;; test-prog-lsp--add-file-watch-ignored-extras.el --- Tests for cj/lsp--add-file-watch-ignored-extras -*- lexical-binding: t; -*- - -;;; Commentary: -;; Tests for cj/lsp--add-file-watch-ignored-extras in prog-lsp.el. -;; The function adds project-agnostic build/cache directory patterns to -;; `lsp-file-watch-ignored-directories' without replacing lsp-mode's -;; defaults. Patterns are sourced from `cj/lsp-file-watch-ignored-extras'. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -;; Declare lsp-mode's defcustom as a special variable so `let' binds it -;; dynamically. Real definition is lsp-mode's; loaded only when use-package -;; activates lsp-mode. In the test environment, this stub provides the value -;; cell `add-to-list' needs. -(defvar lsp-file-watch-ignored-directories nil) -(defvar eldoc-documentation-functions nil) - -(defun lsp-eldoc-function (&rest _args) - "Stub lsp-mode Eldoc function for tests.") - -(require 'prog-lsp) - -;;; Normal Cases - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-normal-adds-all-patterns () - "Normal: every entry from `cj/lsp-file-watch-ignored-extras' lands in the list." - (let ((lsp-file-watch-ignored-directories nil)) - (cj/lsp--add-file-watch-ignored-extras) - (should (= (length lsp-file-watch-ignored-directories) - (length cj/lsp-file-watch-ignored-extras))) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (member pattern lsp-file-watch-ignored-directories))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-normal-extends-not-replaces () - "Normal: pre-existing entries (lsp-mode defaults) are preserved." - (let ((lsp-file-watch-ignored-directories - '("[/\\\\]\\.git\\'" "[/\\\\]\\.svn\\'" "[/\\\\]\\.idea\\'"))) - (cj/lsp--add-file-watch-ignored-extras) - (should (member "[/\\\\]\\.git\\'" lsp-file-watch-ignored-directories)) - (should (member "[/\\\\]\\.svn\\'" lsp-file-watch-ignored-directories)) - (should (member "[/\\\\]\\.idea\\'" lsp-file-watch-ignored-directories)) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (member pattern lsp-file-watch-ignored-directories))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-normal-key-patterns-present () - "Normal: specific expected directory names appear in the constant." - (dolist (name '("node_modules" "target" "__pycache__" ".venv" "venv" - "dist" "coverage" "test-results" "playwright-report" - ".terraform" ".ruff_cache" ".pytest_cache" ".mypy_cache")) - (should (cl-some (lambda (p) (string-match-p (regexp-quote name) p)) - cj/lsp-file-watch-ignored-extras)))) - -;;; Boundary Cases - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-boundary-idempotent () - "Boundary: calling twice doesn't duplicate entries." - (let ((lsp-file-watch-ignored-directories nil)) - (cj/lsp--add-file-watch-ignored-extras) - (cj/lsp--add-file-watch-ignored-extras) - (should (= (length lsp-file-watch-ignored-directories) - (length cj/lsp-file-watch-ignored-extras))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-boundary-all-patterns-non-empty () - "Boundary: every pattern is a non-empty string." - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (stringp pattern)) - (should (not (string-empty-p pattern))))) - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-boundary-all-patterns-valid-regex () - "Boundary: every pattern compiles as a valid Emacs regex." - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (condition-case err - ;; string-match-p compiles the regex; invalid syntax raises invalid-regexp. - (string-match-p pattern "/some/sample/path") - (invalid-regexp - (ert-fail (format "Invalid regex %S: %s" - pattern (error-message-string err))))))) - -;;; Error Cases - -(ert-deftest test-prog-lsp--add-file-watch-ignored-extras-error-non-list-target () - "Error: non-list target value triggers `add-to-list' wrong-type-argument." - (let ((lsp-file-watch-ignored-directories "not-a-list")) - (should-error (cj/lsp--add-file-watch-ignored-extras) - :type 'wrong-type-argument))) - -(ert-deftest test-prog-lsp--remove-eldoc-provider-global-removes-from-default () - "Normal: remove lsp-mode's Eldoc provider from the global hook value. -The per-buffer removal that this replaced raced lsp-mode's own buffer- -local hook population; removing globally before any LSP buffer attaches -makes the absence stick for every subsequent lsp-managed buffer." - (let ((eldoc-documentation-functions - '(lsp-eldoc-function eldoc-documentation-default))) - (cj/lsp--remove-eldoc-provider-global) - (should-not (memq #'lsp-eldoc-function eldoc-documentation-functions)) - (should (memq 'eldoc-documentation-default eldoc-documentation-functions)))) - -(ert-deftest test-prog-lsp--remove-eldoc-provider-global-is-idempotent () - "Boundary: re-running the removal after the provider is gone is a no-op." - (let ((eldoc-documentation-functions '(eldoc-documentation-default))) - (cj/lsp--remove-eldoc-provider-global) - (cj/lsp--remove-eldoc-provider-global) - (should (equal eldoc-documentation-functions - '(eldoc-documentation-default))))) - -(ert-deftest test-prog-lsp--module-no-obsolete-lsp-eldoc-hook-reference () - "Regression: prog-lsp should not reference obsolete `lsp-eldoc-hook'." - (with-temp-buffer - (insert-file-contents (expand-file-name "modules/prog-lsp.el" user-emacs-directory)) - (should-not (re-search-forward "\\_<lsp-eldoc-hook\\_>" nil t)))) - -(provide 'test-prog-lsp--add-file-watch-ignored-extras) -;;; test-prog-lsp--add-file-watch-ignored-extras.el ends here diff --git a/tests/test-prog-lsp.el b/tests/test-prog-lsp.el deleted file mode 100644 index 7e38111d..00000000 --- a/tests/test-prog-lsp.el +++ /dev/null @@ -1,66 +0,0 @@ -;;; test-prog-lsp.el --- Startup smoke test for LSP config resolution -*- lexical-binding: t; -*- - -;;; Commentary: -;; A narrow smoke test of prog-lsp.el, the central LSP module. It pins the -;; invariants that should hold the moment the config loads, before any server -;; starts: lsp-enable-remote stays nil (so TRAMP files don't auto-start a slow -;; LSP), the file-watch-ignore defaults live in one idempotent place, the eldoc -;; provider is stripped from the global hook, and a mode never accrues a -;; duplicate lsp-deferred entry. The generic :config defaults are deferred to -;; lsp-mode's own load (see the make-test no-package-initialize note in -;; CLAUDE.md), so this tests the top-level :init and helper surface, which runs. - -;;; Code: - -(require 'ert) -(require 'cl-lib) -(require 'use-package) -(require 'prog-lsp) - -;; lsp-mode's defcustom isn't loaded under make test, and prog-lsp's bare -;; `(defvar lsp-file-watch-ignored-directories)' only marks it special within -;; that file's unit. Declare it special here too so the `let' bindings below -;; bind dynamically (the helper reads it through the symbol via add-to-list). -(defvar lsp-file-watch-ignored-directories nil) - -(ert-deftest test-prog-lsp-enable-remote-nil () - "Normal: lsp-enable-remote is nil so LSP never auto-starts on TRAMP files." - (should (boundp 'lsp-enable-remote)) - (should (null lsp-enable-remote))) - -(ert-deftest test-prog-lsp-file-watch-adds-extras () - "Normal: the build/cache ignore patterns get appended to lsp's watch-ignore list." - (let ((lsp-file-watch-ignored-directories '("[/\\\\]\\.git\\'"))) - (cj/lsp--add-file-watch-ignored-extras) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (member pattern lsp-file-watch-ignored-directories))) - (should (member "[/\\\\]\\.git\\'" lsp-file-watch-ignored-directories)))) - -(ert-deftest test-prog-lsp-file-watch-idempotent () - "Boundary: adding the extras twice leaves each pattern present exactly once." - (let ((lsp-file-watch-ignored-directories '())) - (cj/lsp--add-file-watch-ignored-extras) - (cj/lsp--add-file-watch-ignored-extras) - (dolist (pattern cj/lsp-file-watch-ignored-extras) - (should (= 1 (cl-count pattern lsp-file-watch-ignored-directories - :test #'equal)))))) - -(ert-deftest test-prog-lsp-eldoc-provider-removed-globally () - "Normal: the global eldoc provider is stripped so lsp can't reattach it." - (let ((eldoc-documentation-functions - (list #'lsp-eldoc-function #'ignore))) - (cj/lsp--remove-eldoc-provider-global) - (should-not (memq 'lsp-eldoc-function eldoc-documentation-functions)) - (should (memq 'ignore eldoc-documentation-functions)))) - -(ert-deftest test-prog-lsp-no-duplicate-mode-hook () - "Boundary: a mode prog-lsp wires never holds more than one lsp-deferred entry. -prog-lsp and the per-language modules both add lsp-deferred for some modes; -add-hook dedups identical symbols, and this pins that invariant so a future -non-symbol (lambda) addition that breaks it gets caught." - (dolist (hook '(c-mode-hook python-mode-hook go-ts-mode-hook)) - (when (boundp hook) - (should (>= 1 (cl-count 'lsp-deferred (symbol-value hook))))))) - -(provide 'test-prog-lsp) -;;; test-prog-lsp.el ends here diff --git a/tests/test-prog-python--lsp-guard.el b/tests/test-prog-python--lsp-guard.el new file mode 100644 index 00000000..071e1ca9 --- /dev/null +++ b/tests/test-prog-python--lsp-guard.el @@ -0,0 +1,64 @@ +;;; test-prog-python--lsp-guard.el --- Python LSP guard tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found lsp-pyright's unguarded :hook lambda calling +;; (require 'lsp-pyright) + (lsp-deferred) on every python-ts buffer, so +;; pyright-less machines got the LSP attach prompt that cj/python-setup's +;; guard exists to prevent. The guarded branch now owns the require and +;; the attach, and both classic and treesit modes run the same setup. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-python) + +(defmacro test-python-guard--setup (pyright-found &rest body) + "Run `cj/python-setup' with pyright presence set to PYRIGHT-FOUND. +Records requires into `required' and lsp attaches into `attached'; +BODY sees both. Package minor modes are stubbed at their boundary." + (declare (indent 1)) + `(let ((required '()) (attached nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'executable-find) + (lambda (&rest _) ,pyright-found)) + ((symbol-function 'require) + (lambda (feature &rest _) (push feature required) feature)) + ((symbol-function 'lsp-deferred) + (lambda () (setq attached t)))) + (with-temp-buffer + (cj/python-setup)) + ,@body))) + +(ert-deftest test-prog-python-setup-pyright-absent-no-lsp () + "Error: without pyright, setup neither loads lsp-pyright nor attaches." + (test-python-guard--setup nil + (should-not (memq 'lsp-pyright required)) + (should-not attached))) + +(ert-deftest test-prog-python-setup-pyright-present-attaches () + "Normal: with pyright on PATH, setup loads lsp-pyright then attaches." + (test-python-guard--setup "/usr/bin/pyright" + (should (memq 'lsp-pyright required)) + (should attached))) + +(ert-deftest test-prog-python-hooks-cover-both-mode-variants () + "Normal: classic and treesit python modes both run the same setup." + (dolist (hook '(python-mode-hook python-ts-mode-hook)) + (should (memq #'cj/python-setup (symbol-value hook))) + (should (memq #'cj/python-mode-keybindings (symbol-value hook))))) + +(ert-deftest test-prog-python-no-anonymous-hook-lambdas () + "Boundary: no anonymous lambda remains on the python hooks. +The audit's unguarded lsp-pyright lambda was anonymous; symbols only +means every hook entry is a named, greppable function." + (dolist (hook '(python-mode-hook python-ts-mode-hook)) + (dolist (fn (symbol-value hook)) + (should (symbolp fn))))) + +(provide 'test-prog-python--lsp-guard) +;;; test-prog-python--lsp-guard.el ends here diff --git a/tests/test-prog-shell--tool-warnings.el b/tests/test-prog-shell--tool-warnings.el new file mode 100644 index 00000000..37c1e559 --- /dev/null +++ b/tests/test-prog-shell--tool-warnings.el @@ -0,0 +1,34 @@ +;;; test-prog-shell--tool-warnings.el --- Load-time missing-tool warnings -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit flagged bash-language-server, shfmt, and shellcheck +;; for the load-time missing-tool warnings pyright/prettier already +;; have. The shfmt and flycheck use-package blocks gate on `:if +;; (executable-find ...)', which evaluates once at startup — an absent +;; tool silently disables that setup until the next restart, so the +;; warn is the only visible trace. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-shell) + +(ert-deftest test-prog-shell-warns-when-tools-missing () + "Error: loading without the shell tools on PATH warns for each one." + (let ((warned '())) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'display-warning) + (lambda (_type msg &rest _) (push msg warned)))) + (load (expand-file-name "modules/prog-shell.el" user-emacs-directory) nil t)) + (dolist (tool '("bash-language-server" "shfmt" "shellcheck")) + (should (cl-some (lambda (m) (string-match-p (regexp-quote tool) m)) + warned))))) + +(provide 'test-prog-shell--tool-warnings) +;;; test-prog-shell--tool-warnings.el ends here diff --git a/tests/test-prog-webdev--classic-and-web-mode-hooks.el b/tests/test-prog-webdev--classic-and-web-mode-hooks.el new file mode 100644 index 00000000..20fc2fb8 --- /dev/null +++ b/tests/test-prog-webdev--classic-and-web-mode-hooks.el @@ -0,0 +1,78 @@ +;;; test-prog-webdev--classic-and-web-mode-hooks.el --- Classic js + web-mode setup hooks -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found the webdev setup hooks attached to the +;; tree-sitter modes only, so a grammar-unavailable fallback to classic +;; js-mode silently lost indent/keys/LSP, and web-mode got the format +;; key but none of the promised setup (no company/flyspell/LSP in HTML +;; buffers). These tests pin the classic js-mode hooks and the +;; web-mode setup hook, plus the html-language-server guard that keeps +;; LSP silent on machines without the server. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-format-wiring) +(format-test--ensure-packages-init) +(require 'prog-webdev) + +(ert-deftest test-prog-webdev-hooks-cover-classic-js-mode () + "Normal: classic js-mode runs the same setup + keybindings as js-ts-mode." + (should (memq #'cj/webdev-setup js-mode-hook)) + (should (memq #'cj/webdev-keybindings js-mode-hook))) + +(ert-deftest test-prog-webdev-web-mode-hook-runs-setup () + "Normal: web-mode runs `cj/web-mode-setup' alongside the keybindings." + (should (memq #'cj/web-mode-setup web-mode-hook)) + (should (memq #'cj/webdev-keybindings web-mode-hook))) + +(ert-deftest test-prog-webdev-web-mode-setup-sets-buffer-local-preferences () + "Normal: web-mode setup lands the shared webdev buffer preferences." + (with-temp-buffer + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) + (cj/web-mode-setup)) + (should (= fill-column 100)) + (should (= tab-width 2)) + (should-not indent-tabs-mode))) + +(ert-deftest test-prog-webdev-web-mode-setup-starts-lsp-when-html-server-on-path () + "Normal: with the html language server on PATH, `lsp-deferred' fires." + (with-temp-buffer + (let ((started nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'lsp-deferred) + (lambda (&rest _) (setq started t))) + ((symbol-function 'executable-find) + (lambda (path &rest _) + (when (equal path html-language-server-path) + "/usr/bin/vscode-html-language-server")))) + (cj/web-mode-setup)) + (should started)))) + +(ert-deftest test-prog-webdev-web-mode-setup-skips-lsp-without-html-server () + "Boundary: without the html language server, `lsp-deferred' is NOT called." + (with-temp-buffer + (let ((started nil)) + (cl-letf (((symbol-function 'company-mode) #'ignore) + ((symbol-function 'flyspell-prog-mode) #'ignore) + ((symbol-function 'superword-mode) #'ignore) + ((symbol-function 'electric-pair-local-mode) #'ignore) + ((symbol-function 'lsp-deferred) + (lambda (&rest _) (setq started t))) + ((symbol-function 'executable-find) (lambda (_ &rest _) nil))) + (cj/web-mode-setup)) + (should-not started)))) + +(provide 'test-prog-webdev--classic-and-web-mode-hooks) +;;; test-prog-webdev--classic-and-web-mode-hooks.el ends here diff --git a/tests/test-restclient-config--keymap.el b/tests/test-restclient-config--keymap.el new file mode 100644 index 00000000..7265c4f3 --- /dev/null +++ b/tests/test-restclient-config--keymap.el @@ -0,0 +1,29 @@ +;;; test-restclient-config--keymap.el --- Tests for the restclient prefix keymap -*- lexical-binding: t -*- + +;;; Commentary: +;; Pins the C-; R prefix wiring. The bindings must go through +;; `cj/restclient-map' + `cj/register-prefix-map' (like the other C-; +;; prefixes), not raw `global-set-key' calls that silently depend on +;; keybindings.el having installed C-; first. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'restclient-config) + +;;; Normal Cases + +(ert-deftest test-restclient-keymap-registered-under-custom-prefix () + "Normal: cj/restclient-map is bound at R inside cj/custom-keymap." + (should (boundp 'cj/restclient-map)) + (should (eq cj/restclient-map (keymap-lookup cj/custom-keymap "R")))) + +(ert-deftest test-restclient-keymap-binds-new-buffer-and-open-file () + "Normal: the prefix map carries the two restclient commands." + (should (eq #'cj/restclient-new-buffer (keymap-lookup cj/restclient-map "n"))) + (should (eq #'cj/restclient-open-file (keymap-lookup cj/restclient-map "o")))) + +(provide 'test-restclient-config--keymap) +;;; test-restclient-config--keymap.el ends here diff --git a/tests/test-show-kill-ring--insert-item.el b/tests/test-show-kill-ring--insert-item.el deleted file mode 100644 index a29ca75e..00000000 --- a/tests/test-show-kill-ring--insert-item.el +++ /dev/null @@ -1,73 +0,0 @@ -;;; test-show-kill-ring--insert-item.el --- Tests for show-kill-insert-item -*- lexical-binding: t -*- - -;;; Commentary: -;; Tests for `show-kill-insert-item' in show-kill-ring.el — inserts a -;; kill-ring entry into the current buffer, truncating to -;; `show-kill-max-item-size' with an ellipsis when too long. The ellipsis -;; sits inline for short items and on its own line for items wider than the -;; frame. Frame width is read at runtime so the test is environment-stable. - -;;; Code: - -(require 'ert) -(require 'show-kill-ring) - -;;; Normal Cases - -(ert-deftest test-show-kill-ring-insert-item-short-verbatim () - "Normal: an item shorter than the max is inserted unchanged." - (let ((show-kill-max-item-size 1000)) - (with-temp-buffer - (show-kill-insert-item "hello") - (should (string= (buffer-string) "hello"))))) - -(ert-deftest test-show-kill-ring-insert-item-inline-ellipsis () - "Normal: an over-max item narrower than the frame gets an inline ellipsis." - (let* ((show-kill-max-item-size 5) - (len (/ (frame-width) 2)) ; > max, < (frame-width - 5) - (item (make-string len ?b))) - (with-temp-buffer - (show-kill-insert-item item) - (should (string= (buffer-string) "bbbbb..."))))) - -;;; Boundary Cases - -(ert-deftest test-show-kill-ring-insert-item-length-equals-max-truncates () - "Boundary: length exactly equal to max truncates — the guard is (< len max)." - (let ((show-kill-max-item-size 5)) - (with-temp-buffer - (show-kill-insert-item "hello") ; length 5, equals max - (should (string= (buffer-string) "hello..."))))) - -(ert-deftest test-show-kill-ring-insert-item-wide-newline-ellipsis () - "Boundary: an item wider than the frame puts the ellipsis on its own line." - (let* ((show-kill-max-item-size 5) - (item (make-string (+ (frame-width) 10) ?a))) - (with-temp-buffer - (show-kill-insert-item item) - (should (string= (buffer-string) "aaaaa\n..."))))) - -(ert-deftest test-show-kill-ring-insert-item-max-nil-verbatim () - "Boundary: a non-numeric max disables truncation." - (let ((show-kill-max-item-size nil)) - (with-temp-buffer - (show-kill-insert-item "anything long enough to exceed nothing") - (should (string= (buffer-string) - "anything long enough to exceed nothing"))))) - -(ert-deftest test-show-kill-ring-insert-item-max-negative-verbatim () - "Boundary: a negative max disables truncation." - (let ((show-kill-max-item-size -1)) - (with-temp-buffer - (show-kill-insert-item "abc") - (should (string= (buffer-string) "abc"))))) - -(ert-deftest test-show-kill-ring-insert-item-empty-string () - "Boundary: an empty item inserts nothing and does not error." - (let ((show-kill-max-item-size 1000)) - (with-temp-buffer - (show-kill-insert-item "") - (should (string= (buffer-string) ""))))) - -(provide 'test-show-kill-ring--insert-item) -;;; test-show-kill-ring--insert-item.el ends here diff --git a/tests/test-signal-config-notify.el b/tests/test-signal-config-notify.el deleted file mode 100644 index 1a772289..00000000 --- a/tests/test-signal-config-notify.el +++ /dev/null @@ -1,150 +0,0 @@ -;;; test-signal-config-notify.el --- Tests for the signal-config notification slice -*- lexical-binding: t -*- - -;;; Commentary: -;; ERT tests for the notification slice of `signal-config': the pure -;; body formatter (whitespace collapse + truncation to -;; `cj/signal--notify-body-max') and `cj/signel--notify' routing (the -;; suppression gate, the notify-script path with the sound flag, and -;; the `notifications-notify' fallback). Spec: the "Notification -;; slice" addendum in docs/specs/signal-client-spec-doing.org. No signal-cli or -;; linked account needed. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -;; signel is the fork at ~/code/signel; signal-config wires it via -;; use-package but these tests need the symbols available directly. -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(require 'signal-config) - -;;; cj/signal--format-notify-body - -(ert-deftest test-signal-config-format-notify-body-passthrough () - "Normal: short single-line text passes through unchanged." - (should (equal (cj/signal--format-notify-body "lunch at noon?") - "lunch at noon?"))) - -(ert-deftest test-signal-config-format-notify-body-collapses-whitespace () - "Normal: newlines and whitespace runs collapse to single spaces." - (should (equal (cj/signal--format-notify-body "two\nlines\n\nhere") - "two lines here")) - (should (equal (cj/signal--format-notify-body "tabs\t\tand spaces") - "tabs and spaces"))) - -(ert-deftest test-signal-config-format-notify-body-trims () - "Boundary: leading and trailing whitespace is trimmed." - (should (equal (cj/signal--format-notify-body " hi ") "hi"))) - -(ert-deftest test-signal-config-format-notify-body-empty () - "Boundary: the empty string stays empty." - (should (equal (cj/signal--format-notify-body "") ""))) - -(ert-deftest test-signal-config-format-notify-body-exact-limit () - "Boundary: a body exactly at the limit is untouched." - (let ((s (make-string cj/signal--notify-body-max ?x))) - (should (equal (cj/signal--format-notify-body s) s)))) - -(ert-deftest test-signal-config-format-notify-body-truncates-over-limit () - "Boundary: over-limit text truncates to the limit, ending in an ellipsis." - (let* ((s (make-string (1+ cj/signal--notify-body-max) ?x)) - (out (cj/signal--format-notify-body s))) - (should (= (length out) cj/signal--notify-body-max)) - (should (string-suffix-p "…" out)))) - -(ert-deftest test-signal-config-format-notify-body-unicode () - "Boundary: multibyte text truncates by characters, not bytes." - (let* ((s (make-string (+ cj/signal--notify-body-max 10) ?é)) - (out (cj/signal--format-notify-body s))) - (should (= (length out) cj/signal--notify-body-max)) - (should (string-suffix-p "…" out)))) - -;;; cj/signel--notify routing - -(ert-deftest test-signal-config-notify-suppressed-when-viewing () - "Normal: nothing fires when the suppression predicate says no." - (let (script-calls fallback-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) nil)) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil)) - ((symbol-function 'notifications-notify) - (lambda (&rest args) (push args fallback-calls) nil))) - (cj/signel--notify "+15551234567" "Alice" "hi")) - (should-not script-calls) - (should-not fallback-calls))) - -(ert-deftest test-signal-config-notify-script-silent-by-default () - "Normal: with the script present and sound off, runs notify info --silent." - (let (script-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (p &optional _remote) - (when (equal p "notify") "/usr/bin/notify"))) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil)) - ((symbol-function 'notifications-notify) - (lambda (&rest _) - (error "Fallback must not fire when the script is present")))) - (let ((cj/signel-notify-sound nil)) - (cj/signel--notify "+15551234567" "Alice" "hi"))) - (should (= (length script-calls) 1)) - ;; start-process args: (NAME BUFFER PROGRAM &rest PROGRAM-ARGS); - ;; PROGRAM is the path executable-find resolved, not the bare name. - (should (equal (nthcdr 2 (car script-calls)) - '("/usr/bin/notify" "info" "Signal: Alice" "hi" "--silent"))))) - -(ert-deftest test-signal-config-notify-sound-enabled-drops-silent () - "Normal: with `cj/signel-notify-sound' non-nil, --silent is omitted." - (let (script-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (p &optional _remote) - (when (equal p "notify") "/usr/bin/notify"))) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil))) - (let ((cj/signel-notify-sound t)) - (cj/signel--notify "+15551234567" "Alice" "hi"))) - (should (equal (nthcdr 2 (car script-calls)) - '("/usr/bin/notify" "info" "Signal: Alice" "hi"))))) - -(ert-deftest test-signal-config-notify-fallback-when-script-missing () - "Error: without the script on PATH, falls back to notifications-notify." - (let (script-calls fallback-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (_p &optional _remote) nil)) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil)) - ((symbol-function 'notifications-notify) - (lambda (&rest args) (push args fallback-calls) nil))) - (cj/signel--notify "+15551234567" "Alice" "hi")) - (should-not script-calls) - (should (= (length fallback-calls) 1)) - (let ((args (car fallback-calls))) - (should (equal (plist-get args :title) "Signal: Alice")) - (should (equal (plist-get args :body) "hi"))))) - -(ert-deftest test-signal-config-notify-formats-body-before-send () - "Normal: the body runs through the formatter before reaching the script." - (let (script-calls) - (cl-letf (((symbol-function 'cj/signal--should-notify-p) - (lambda (_chat-id) t)) - ((symbol-function 'executable-find) - (lambda (p &optional _remote) - (when (equal p "notify") "/usr/bin/notify"))) - ((symbol-function 'start-process) - (lambda (&rest args) (push args script-calls) nil))) - (let ((cj/signel-notify-sound nil)) - (cj/signel--notify "+15551234567" "Alice" "first line\nsecond line"))) - (should (equal (nth 5 (car script-calls)) "first line second line")))) - -(provide 'test-signal-config-notify) -;;; test-signal-config-notify.el ends here diff --git a/tests/test-signal-config.el b/tests/test-signal-config.el deleted file mode 100644 index 7556efdb..00000000 --- a/tests/test-signal-config.el +++ /dev/null @@ -1,407 +0,0 @@ -;;; test-signal-config.el --- Tests for signal-config -*- lexical-binding: t -*- - -;;; Commentary: -;; ERT tests for the pure helper layer of `signal-config': contact-list -;; parsing for the contact picker, and the notify-when-not-viewing -;; predicate. These need neither signal-cli nor a linked account. - -;;; Code: - -(require 'ert) -(require 'cl-lib) -(require 'json) - -;; signel is the fork at ~/code/signel; signal-config wires it via -;; use-package but the connection-guard/fetch tests need the symbols -;; available directly. -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(require 'signal-config) - -;;; cj/signal--jstr - -(ert-deftest test-signal-config-jstr-string () - "Normal: a non-blank string passes through unchanged." - (should (equal (cj/signal--jstr "hi") "hi"))) - -(ert-deftest test-signal-config-jstr-rejects-nonstrings () - "Boundary/Error: nil, empty, whitespace, and non-string sentinels become nil." - (should-not (cj/signal--jstr nil)) - (should-not (cj/signal--jstr "")) - (should-not (cj/signal--jstr " ")) - (should-not (cj/signal--jstr :null)) - (should-not (cj/signal--jstr 42))) - -;;; cj/signal--contact-display-name -;; Field priority: nickName, then nickGiven+nickFamily, then top-level name, -;; then top-level given+family, then profile given+family, then username. - -(ert-deftest test-signal-config-display-name-prefers-name () - "Normal: the top-level combined name wins over the given/family parts." - (should (equal (cj/signal--contact-display-name - '((name . "Alice Anderson") (givenName . "Ali") (familyName . "A"))) - "Alice Anderson"))) - -(ert-deftest test-signal-config-display-name-nickname-wins () - "Normal: a nickName overrides the contact name." - (should (equal (cj/signal--contact-display-name - '((nickName . "Edster") (name . "Eve Edwards") - (givenName . "Eve") (familyName . "Edwards"))) - "Edster"))) - -(ert-deftest test-signal-config-display-name-nickname-parts () - "Boundary: nickGivenName+nickFamilyName combine when nickName is unset." - (should (equal (cj/signal--contact-display-name - '((nickGivenName . "DJ") (nickFamilyName . "Cool") (name . "Daniel"))) - "DJ Cool"))) - -(ert-deftest test-signal-config-display-name-toplevel-given-family () - "Boundary: with no name, top-level givenName+familyName combine." - (should (equal (cj/signal--contact-display-name - '((name) (givenName . "Bob") (familyName . "Brown"))) - "Bob Brown"))) - -(ert-deftest test-signal-config-display-name-profile-fallback () - "Boundary: with no name or top-level parts, profile given/family is the fallback." - (should (equal (cj/signal--contact-display-name - '((name) (givenName) (familyName) - (profile . ((givenName . "Carol") (familyName))))) - "Carol"))) - -(ert-deftest test-signal-config-display-name-username-fallback () - "Boundary: username is the last name source." - (should (equal (cj/signal--contact-display-name - '((name) (username . "dave.42"))) - "dave.42"))) - -(ert-deftest test-signal-config-display-name-none () - "Error: no usable name yields nil." - (should-not (cj/signal--contact-display-name - '((name) (givenName) (familyName) - (profile . ((givenName) (familyName)))))) - (should-not (cj/signal--contact-display-name '((number . "+15551112222"))))) - -;;; cj/signal--parse-contacts - -(defconst test-signal-config--contacts-json - "[ - {\"number\":\"+15551112222\",\"uuid\":\"uuid-a\",\"name\":\"Alice Anderson\",\"givenName\":\"Alice\",\"familyName\":\"Anderson\",\"nickName\":null,\"nickGivenName\":null,\"nickFamilyName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, - {\"number\":\"+15553334444\",\"uuid\":null,\"name\":null,\"givenName\":\"Bob\",\"familyName\":\"Brown\",\"nickName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, - {\"number\":\"+15555556666\",\"uuid\":\"uuid-c\",\"name\":null,\"givenName\":null,\"familyName\":null,\"nickName\":null,\"username\":null,\"profile\":{\"givenName\":\"Carol\",\"familyName\":null}}, - {\"number\":null,\"uuid\":\"uuid-d\",\"name\":null,\"givenName\":null,\"familyName\":null,\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}}, - {\"number\":\"+15557778888\",\"uuid\":\"uuid-e\",\"name\":\"Eve Edwards\",\"givenName\":\"Eve\",\"familyName\":\"Edwards\",\"nickName\":\"Edster\",\"username\":null,\"profile\":{\"givenName\":null,\"familyName\":null}} -]" - "Synthetic fixture mirroring the signal-cli 0.14.4.1 `listContacts' shape: -top-level name/givenName/familyName and nickName fields, with a profile -sub-object whose name fields are usually null. Field layout was confirmed -against a live linked account on 2026-05-26; the values here are fake.") - -(ert-deftest test-signal-config-parse-contacts-normal () - "Normal: top-level name, top-level parts, profile fallback, uuid fallback, nickname." - (let* ((result (json-read-from-string test-signal-config--contacts-json)) - (pairs (cj/signal--parse-contacts result))) - (should (equal pairs - '(("Alice Anderson (+15551112222)" . "+15551112222") - ("Bob Brown (+15553334444)" . "+15553334444") - ("Carol (+15555556666)" . "+15555556666") - ("Edster (+15557778888)" . "+15557778888") - ("uuid-d" . "uuid-d")))))) - -(ert-deftest test-signal-config-parse-contacts-empty () - "Boundary: an empty result yields nil for both vector and nil input." - (should-not (cj/signal--parse-contacts [])) - (should-not (cj/signal--parse-contacts nil))) - -(ert-deftest test-signal-config-parse-contacts-accepts-list-and-vector () - "Boundary: vector and list result sequences parse identically." - (let ((entry '((number . "+15551112222") (name . "Al")))) - (should (equal (cj/signal--parse-contacts (vector entry)) - (cj/signal--parse-contacts (list entry)))))) - -(ert-deftest test-signal-config-parse-contacts-drops-recipientless () - "Error: a contact with neither number nor uuid is dropped." - (should-not (cj/signal--parse-contacts - (list '((name . "Ghost") (number) (uuid)))))) - -;;; cj/signal--suppress-notify-p - -(ert-deftest test-signal-config-suppress-when-viewing-focused () - "Normal: viewing the chat buffer with focus suppresses the notification." - (should (cj/signal--suppress-notify-p - "+15551112222" "*Signel: +15551112222*" t))) - -(ert-deftest test-signal-config-no-suppress-other-buffer () - "Boundary: a different selected buffer does not suppress." - (should-not (cj/signal--suppress-notify-p - "+15551112222" "*scratch*" t))) - -(ert-deftest test-signal-config-no-suppress-unfocused () - "Boundary: viewing the chat but with the frame unfocused still notifies." - (should-not (cj/signal--suppress-notify-p - "+15551112222" "*Signel: +15551112222*" nil))) - -(ert-deftest test-signal-config-no-suppress-nil-viewing () - "Error: a nil viewing-buffer name does not suppress." - (should-not (cj/signal--suppress-notify-p "+15551112222" nil t))) - -;;; cj/signel--ensure-started - -(ert-deftest test-signal-config-ensure-started-live-process-noop () - "Normal: with a live signel process, ensure-started returns without -calling `signel-start' or the pre-warm fetch." - (let ((start-called nil) - (fetch-called nil)) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) t)) - ((symbol-function 'get-process) (lambda (_) 'fake-proc)) - ((symbol-function 'signel-start) - (lambda () (setq start-called t))) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) (setq fetch-called t)))) - (cj/signel--ensure-started) - (should-not start-called) - (should-not fetch-called)))) - -(ert-deftest test-signal-config-ensure-started-starts-when-account-set () - "Normal: with `signel-account' set and no live process, ensure-started -calls `signel-start' to bring the daemon up." - (let ((start-called nil) - (signel-account "+15555550100")) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'get-process) (lambda (_) nil)) - ((symbol-function 'signel-start) - (lambda () (setq start-called t))) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) nil))) - (cj/signel--ensure-started) - (should start-called)))) - -(ert-deftest test-signal-config-ensure-started-prewarms-on-start () - "Normal: when ensure-started actually starts the daemon, it triggers a -pre-warm fetch so the picker cache is warm on first invocation." - (let ((fetch-called nil) - (signel-account "+15555550100")) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'get-process) (lambda (_) nil)) - ((symbol-function 'signel-start) (lambda () nil)) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) (setq fetch-called t)))) - (cj/signel--ensure-started) - (should fetch-called)))) - -(ert-deftest test-signal-config-ensure-started-errors-when-no-account () - "Error: with `signel-account' nil, ensure-started signals a user-error -naming the remedy (set the account in the private config) instead of -starting an account-less daemon." - (let ((signel-account nil)) - (cl-letf (((symbol-function 'process-live-p) (lambda (_) nil)) - ((symbol-function 'get-process) (lambda (_) nil))) - (should-error (cj/signel--ensure-started) :type 'user-error)))) - -(ert-deftest test-signal-config-ensure-started-requires-signel-first () - "Error: ensure-started must `require' signel BEFORE reading any of -its private variables, so a `void-variable' error cannot fire when -called before signel has been autoloaded. Captures the bug where -`signel--process-name' was forward-declared in signal-config but not -yet bound at runtime because the `use-package' autoload had not fired. - -Asserts ordering, not just presence: a future refactor that moves the -`require' below the `cond' would still execute the require eventually -but the variable read in the cond would fire void-variable first. -The test fails if `require' isn't the first call inside the function." - (let ((call-order nil)) - (cl-letf (((symbol-function 'require) - (lambda (feature &optional _filename _noerror) - (push (list 'require feature) call-order) - t)) - ((symbol-function 'process-live-p) - (lambda (_) (push 'process-live-p call-order) t)) - ((symbol-function 'get-process) - (lambda (_) (push 'get-process call-order) 'fake-proc))) - (cj/signel--ensure-started) - (should (equal (car (reverse call-order)) '(require signel)))))) - -;;; cj/signel--fetch-contacts + cj/signel--contact-cache - -(ert-deftest test-signal-config-fetch-contacts-issues-list-contacts-rpc () - "Normal: fetch-contacts sends a `listContacts' RPC and registers a -success callback so the response routes back." - (let (sent-method sent-callback) - (cl-letf (((symbol-function 'signel--send-rpc) - (lambda (method _params _target callback) - (setq sent-method method - sent-callback callback) - 1))) - (cj/signel--fetch-contacts)) - (should (equal sent-method "listContacts")) - (should (functionp sent-callback)))) - -(ert-deftest test-signal-config-fetch-contacts-callback-populates-cache () - "Normal: on a successful result, the callback parses the contact list -and stores the (LABEL . RECIPIENT) alist in `cj/signel--contact-cache'." - (let (sent-callback) - (cl-letf (((symbol-function 'signel--send-rpc) - (lambda (_method _params _target callback) - (setq sent-callback callback) 1))) - (setq cj/signel--contact-cache nil) - (cj/signel--fetch-contacts) - (funcall sent-callback - [((number . "+15555550100") (givenName . "Alice"))])) - (should (equal cj/signel--contact-cache - '(("Alice (+15555550100)" . "+15555550100")))))) - -(ert-deftest test-signal-config-fetch-contacts-empty-result-clears-cache () - "Boundary: an empty listContacts result populates the cache as nil, -distinct from a failure path (which never invokes the success callback)." - (let (sent-callback) - (cl-letf (((symbol-function 'signel--send-rpc) - (lambda (_method _params _target callback) - (setq sent-callback callback) 1))) - (setq cj/signel--contact-cache '(("stale" . "+10000000000"))) - (cj/signel--fetch-contacts) - (funcall sent-callback [])) - (should-not cj/signel--contact-cache))) - -;;; cj/signel-refresh-contacts - -(ert-deftest test-signal-config-refresh-contacts-clears-and-refetches () - "Normal: `cj/signel-refresh-contacts' clears the cache and triggers a -fresh fetch so a stale entry can't survive a user-driven refresh." - (let ((fetch-called nil)) - (setq cj/signel--contact-cache '(("stale" . "+10000000000"))) - (cl-letf (((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) (setq fetch-called t)))) - (cj/signel-refresh-contacts)) - (should-not cj/signel--contact-cache) - (should fetch-called))) - -;;; cj/signel-message picker - -(ert-deftest test-signal-config-message-warm-cache-picks-contact () - "Normal: with a warm cache, picking a contact label opens that -recipient's chat buffer." - (let ((chosen-recipient nil) - (signel-account "+15555550100")) - (setq cj/signel--contact-cache - '(("Alice (+15555550200)" . "+15555550200"))) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'completing-read) - (lambda (&rest _) "Alice (+15555550200)")) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message)) - (should (equal chosen-recipient "+15555550200")))) - -(ert-deftest test-signal-config-message-warm-cache-picks-note-to-self () - "Normal: the pinned `Note to Self' entry resolves to `signel-account' -so a self-message lands in the Signal Note-to-Self thread." - (let ((chosen-recipient nil) - (signel-account "+15555550100")) - (setq cj/signel--contact-cache - '(("Alice (+15555550200)" . "+15555550200"))) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'completing-read) - (lambda (&rest _) "Note to Self")) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message)) - (should (equal chosen-recipient "+15555550100")))) - -(ert-deftest test-signal-config-message-cold-cache-fetch-resolves-in-time () - "Normal: cold cache, fetch's after-callback fires inside the bounded -wait, picker proceeds with the now-warm cache." - (let ((chosen-recipient nil) - (signel-account "+15555550100") - (cj/signel-fetch-timeout 1.0)) - (setq cj/signel--contact-cache nil) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&optional after-cb) - (setq cj/signel--contact-cache - '(("Bob (+15555550300)" . "+15555550300"))) - (when after-cb (funcall after-cb)))) - ((symbol-function 'completing-read) - (lambda (&rest _) "Bob (+15555550300)")) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message)) - (should (equal chosen-recipient "+15555550300")))) - -(ert-deftest test-signal-config-message-cold-cache-timeout-errors () - "Error: cold cache, fetch never resolves, picker user-errors before -the bounded wait would let Emacs hang on a dead daemon." - (let ((signel-account "+15555550100") - (cj/signel-fetch-timeout 0.1)) - (setq cj/signel--contact-cache nil) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'cj/signel--fetch-contacts) - (lambda (&rest _) nil))) - (should-error (cj/signel-message) :type 'user-error)))) - -;;; cj/signel-message-self - -(ert-deftest test-signal-config-message-self-calls-signel-chat-with-account () - "Normal: the direct self-message command opens a chat buffer addressed -to `signel-account', skipping the picker entirely." - (let ((chosen-recipient nil) - (signel-account "+15555550100")) - (cl-letf (((symbol-function 'cj/signel--ensure-started) (lambda () nil)) - ((symbol-function 'signel-chat) - (lambda (r) (setq chosen-recipient r)))) - (cj/signel-message-self)) - (should (equal chosen-recipient "+15555550100")))) - -;;; cj/signel-prefix-map (C-; M) - -(ert-deftest test-signal-config-prefix-map-has-expected-bindings () - "Normal: the signel C-; M prefix map binds m / s / d / q / SPC to the -commands the workflow spec names." - (should (eq (keymap-lookup cj/signel-prefix-map "m") - #'cj/signel-message)) - (should (eq (keymap-lookup cj/signel-prefix-map "s") - #'cj/signel-message-self)) - (should (eq (keymap-lookup cj/signel-prefix-map "d") - #'signel-dashboard)) - (should (eq (keymap-lookup cj/signel-prefix-map "q") - #'signel-stop)) - (should (eq (keymap-lookup cj/signel-prefix-map "SPC") - #'cj/signel-connect))) - -(ert-deftest test-signal-config-prefix-map-registered-under-c-semi-m () - "Normal: loading signal-config registers `cj/signel-prefix-map' under -`M' in `cj/custom-keymap', so C-; M reaches the signel prefix. Guards -the wiring contract that the load-order bug broke: signal-config must -register through `cj/register-prefix-map', not a boundp-guarded direct -mutation that silently no-ops when keybindings loaded in a different -order." - (require 'keybindings) - (should (eq (keymap-lookup cj/custom-keymap "M") cj/signel-prefix-map))) - -;;; display-buffer-alist entry for *Signel: ...* chat buffers - -(ert-deftest test-signal-config-chat-buffer-display-rule-uses-bottom-30 () - "Normal: signal-config registers a `display-buffer-alist' entry that -matches `*Signel: <id>*' buffers, routes them through -`display-buffer-at-bottom', and sets `window-height' to 0.3 so the -chat docks to the bottom 30% of the frame." - (let ((entry (seq-find (lambda (e) (equal (car e) "\\`\\*Signel: ")) - display-buffer-alist))) - (should entry) - (should (memq 'display-buffer-at-bottom (cadr entry))) - (should (equal 0.3 (cdr (assq 'window-height (cddr entry))))))) - -(ert-deftest test-signal-config-chat-buffer-display-rule-matches-buffer-name () - "Boundary: the registered regex matches a realistic chat buffer name -\(phone-number id and group-id) and does not match unrelated buffers." - (let* ((entry (seq-find (lambda (e) (equal (car e) "\\`\\*Signel: ")) - display-buffer-alist)) - (regex (car entry))) - (should regex) - (should (string-match-p regex "*Signel: +15555550100*")) - (should (string-match-p regex "*Signel: groupid-abc*")) - (should-not (string-match-p regex "*signel-log*")) - (should-not (string-match-p regex "scratch")))) - -(provide 'test-signal-config) -;;; test-signal-config.el ends here diff --git a/tests/test-signel-cancel-input.el b/tests/test-signel-cancel-input.el deleted file mode 100644 index b2a7ef89..00000000 --- a/tests/test-signel-cancel-input.el +++ /dev/null @@ -1,74 +0,0 @@ -;;; test-signel-cancel-input.el --- Cancel-input contract for the signel fork -*- lexical-binding: t; -*- - -;;; Commentary: -;; `signel--cancel-input' is the C-c C-k handler in `signel-chat-mode'. -;; Its contract: clear any in-progress input between `signel--input-marker' -;; and `point-max' (so the prompt is fresh on next visit), then dismiss -;; the window via `quit-window' (the buffer stays alive so chat history -;; survives revisits). These tests lock the contract; the binding test -;; locks the keymap entry. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defmacro test-signel-cancel--with-chat-buffer (&rest body) - "Set up a temp signel-chat-mode buffer with prompt drawn and run BODY." - (declare (indent 0)) - `(with-temp-buffer - (signel-chat-mode) - (setq signel--chat-id "+15555550100") - (signel--draw-prompt) - ,@body)) - -(ert-deftest test-signel-cancel-input-clears-pending-text () - "Normal: pending input from input-marker to point-max is cleared." - (test-signel-cancel--with-chat-buffer - (insert "abandoned-draft") - (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) - (signel--cancel-input)) - (should-not (signel--pending-input)))) - -(ert-deftest test-signel-cancel-input-empty-input-area-is-a-noop () - "Boundary: cancelling with no in-progress input is harmless." - (test-signel-cancel--with-chat-buffer - (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) - (signel--cancel-input)) - (should-not (signel--pending-input)))) - -(ert-deftest test-signel-cancel-input-calls-quit-window () - "Normal: cancel dismisses the window via `quit-window'." - (test-signel-cancel--with-chat-buffer - (insert "abandoned-draft") - (let ((called nil)) - (cl-letf (((symbol-function 'quit-window) - (lambda (&rest _) (setq called t)))) - (signel--cancel-input)) - (should called)))) - -(ert-deftest test-signel-cancel-input-preserves-buffer () - "Normal: cancel does not kill the buffer; chat history (prompt + prior -content above the input marker) survives so reopening the contact lands -in the same buffer." - (test-signel-cancel--with-chat-buffer - (insert "abandoned-draft") - (let ((buf (current-buffer))) - (cl-letf (((symbol-function 'quit-window) (lambda (&rest _) nil))) - (signel--cancel-input)) - (should (buffer-live-p buf))))) - -(ert-deftest test-signel-chat-mode-binds-c-c-c-k-to-cancel () - "Normal: `signel-chat-mode' binds C-c C-k to `signel--cancel-input' so -the documented cancel gesture reaches the handler." - (with-temp-buffer - (signel-chat-mode) - (should (eq (lookup-key (current-local-map) (kbd "C-c C-k")) - #'signel--cancel-input)))) - -(provide 'test-signel-cancel-input) -;;; test-signel-cancel-input.el ends here diff --git a/tests/test-signel-input-preservation.el b/tests/test-signel-input-preservation.el deleted file mode 100644 index e8ce4ddb..00000000 --- a/tests/test-signel-input-preservation.el +++ /dev/null @@ -1,68 +0,0 @@ -;;; test-signel-input-preservation.el --- Regression for signel #2 input clobber -*- lexical-binding: t; -*- - -;;; Commentary: -;; signel-chat-mode buffers have an editable prompt area starting at -;; `signel--input-marker'. Before this fix, both `signel--insert-msg' (the -;; receive path) and `signel--insert-system-msg' (the RPC-error path) -;; called `(delete-region (point) (point-max))' to clear the old prompt -;; before redrawing it, which destroyed any text the user was mid-typing. -;; -;; These tests lock the preservation contract: a small `signel--pending-input' -;; helper captures the in-progress input from the marker to `point-max', and -;; both inserters restore it after the freshly drawn prompt. The chat-mode -;; buffer is constructed in a temp buffer; `signel--insert-msg' is steered -;; to it via a stub on `signel--get-buffer'. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defmacro test-signel--with-chat-buffer (&rest body) - "Set up a temp signel-chat-mode buffer with prompt drawn and run BODY." - (declare (indent 0)) - `(with-temp-buffer - (signel-chat-mode) - (setq signel--chat-id "+15555550100") - (signel--draw-prompt) - ,@body)) - -(ert-deftest test-signel-input-pending-returns-typed-text () - "Normal: with text after the prompt marker, `signel--pending-input' -returns the captured text." - (test-signel--with-chat-buffer - (insert "halfwritten") - (should (equal (signel--pending-input) "halfwritten")))) - -(ert-deftest test-signel-input-pending-returns-nil-when-empty () - "Boundary: an empty input area returns nil so callers don't restore an -empty string after the prompt." - (test-signel--with-chat-buffer - (should-not (signel--pending-input)))) - -(ert-deftest test-signel-input-system-msg-preserves-pending-input () - "Regression for #2: `signel--insert-system-msg' redraws the prompt -without clobbering text the user was mid-typing." - (test-signel--with-chat-buffer - (insert "halfwritten") - (signel--insert-system-msg "An error happened" 'signel-error-face) - (should (string-match-p "An error happened" (buffer-string))) - (should (equal (signel--pending-input) "halfwritten")))) - -(ert-deftest test-signel-input-msg-preserves-pending-input () - "Regression for #2: `signel--insert-msg' (the receive path) redraws the -prompt without clobbering the user's in-progress input." - (test-signel--with-chat-buffer - (insert "halfwritten") - (cl-letf (((symbol-function 'signel--get-buffer) - (lambda (_) (current-buffer)))) - (signel--insert-msg "+15555550100" "Alice" "Hi there" nil nil nil)) - (should (string-match-p "Hi there" (buffer-string))) - (should (equal (signel--pending-input) "halfwritten")))) - -(provide 'test-signel-input-preservation) -;;; test-signel-input-preservation.el ends here diff --git a/tests/test-signel-notify-function.el b/tests/test-signel-notify-function.el deleted file mode 100644 index e3d97af5..00000000 --- a/tests/test-signel-notify-function.el +++ /dev/null @@ -1,89 +0,0 @@ -;;; test-signel-notify-function.el --- Tests for signel's notify-function dispatch -*- lexical-binding: t -*- - -;;; Commentary: -;; signel's receive handler (signel.el in the fork at ~/code/signel) -;; raised notifications through a hardwired `notifications-notify' -;; call. The notification slice (docs/specs/signal-client-spec-doing.org, -;; "Notification slice" addendum) replaces that with -;; `signel-notify-function', a customization point called with -;; CHAT-ID, SENDER, and BODY so a config layer can add suppression or -;; route through an external notifier. These tests cover the -;; dispatch: text, sticker, and attachment bodies reach the function -;; with the right arguments, and the default preserves the plain -;; `notifications-notify' behavior. -;; -;; `signel--handle-receive' is exercised directly with synthetic -;; envelope alists; buffer/dashboard side effects are stubbed. No -;; live process needed. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defun test-signel-notify--receive (envelope) - "Run `signel--handle-receive' on ENVELOPE, capturing notify calls. -Returns the list of (CHAT-ID SENDER BODY) argument lists the handler -passed to `signel-notify-function', oldest first. Buffer and -dashboard side effects are stubbed out." - (let (calls) - (cl-letf (((symbol-function 'signel--insert-msg) (lambda (&rest _) nil)) - ((symbol-function 'signel--dashboard-refresh) (lambda () nil)) - ((symbol-function 'signel--get-buffer) - (lambda (_) (current-buffer)))) - (let ((signel-notify-function - (lambda (chat-id sender body) - (push (list chat-id sender body) calls))) - (signel-auto-open-buffer nil)) - (signel--handle-receive `((envelope . ,envelope))))) - (nreverse calls))) - -(ert-deftest test-signel-notify-function-text-message () - "Normal: a text dataMessage calls the function with chat-id, sender, text." - (should (equal (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (dataMessage . ((message . "hi there"))))) - '(("+15551234567" "Alice" "hi there"))))) - -(ert-deftest test-signel-notify-function-sticker-placeholder () - "Boundary: a sticker with no text gets the [Sticker] placeholder body." - (should (equal (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (dataMessage . ((sticker . ((packId . "p1"))))))) - '(("+15551234567" "Alice" "[Sticker]"))))) - -(ert-deftest test-signel-notify-function-attachment-placeholder () - "Boundary: an attachment with no text gets the [Attachment] placeholder." - (should (equal (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (dataMessage . ((attachments . [((id . "a1"))]))))) - '(("+15551234567" "Alice" "[Attachment]"))))) - -(ert-deftest test-signel-notify-function-no-data-no-call () - "Boundary: an envelope with no dataMessage never calls the function." - (should-not (test-signel-notify--receive - '((sourceNumber . "+15551234567") - (sourceName . "Alice") - (typingMessage . ((action . "STARTED"))))))) - -(ert-deftest test-signel-notify-function-default-preserves-behavior () - "Normal: the default value raises a plain notifications-notify toast." - (should (eq signel-notify-function #'signel--notify-default)) - (let (calls) - (cl-letf (((symbol-function 'notifications-notify) - (lambda (&rest args) (push args calls) nil))) - (signel--notify-default "+15551234567" "Alice" "hi")) - (should (= (length calls) 1)) - (let ((args (car calls))) - (should (equal (plist-get args :title) "Signel: Alice")) - (should (equal (plist-get args :body) "hi"))))) - -(provide 'test-signel-notify-function) -;;; test-signel-notify-function.el ends here diff --git a/tests/test-signel-rpc-dispatch.el b/tests/test-signel-rpc-dispatch.el deleted file mode 100644 index 5ae023d6..00000000 --- a/tests/test-signel-rpc-dispatch.el +++ /dev/null @@ -1,94 +0,0 @@ -;;; test-signel-rpc-dispatch.el --- Tests for signel JSON-RPC success-result dispatch -*- lexical-binding: t; -*- - -;;; Commentary: -;; signel's JSON-RPC dispatch (signel.el in the fork at ~/code/signel) routes -;; incoming `receive' notifications and errors, but successful -;; `((id . N) (result . VALUE))' responses had no path until this work added a -;; request-callback table. These tests cover the new behavior: a registered -;; callback fires with the result and is then removed; an error response -;; also removes the handler so a retry starts clean; an unregistered id is a -;; silent no-op; passing SUCCESS-CALLBACK to `signel--send-rpc' registers it -;; under the returned id. -;; -;; The dispatch tests exercise `signel--dispatch' directly with synthetic JSON -;; alists; no live process is needed. The send-rpc test stubs `get-process' -;; and `process-send-string' so it doesn't require a running signal-cli. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(eval-and-compile - (add-to-list 'load-path (expand-file-name "~/code/signel"))) -(require 'signel) - -(defun test-signel-rpc--reset () - "Reset signel dispatch state to a clean baseline before each test." - (clrhash signel--request-handler-map) - (clrhash signel--request-buffer-map) - (setq signel--rpc-id-counter 0)) - -(ert-deftest test-signel-rpc-dispatch-result-invokes-callback () - "Normal: a result response with a registered id fires the callback with the -result value and removes the handler." - (test-signel-rpc--reset) - (let ((captured nil)) - (puthash 7 (lambda (val) (setq captured val)) signel--request-handler-map) - (signel--dispatch '((jsonrpc . "2.0") (id . 7) - (result . ((contacts . [1 2 3]))))) - (should (equal captured '((contacts . [1 2 3])))) - (should-not (gethash 7 signel--request-handler-map)))) - -(ert-deftest test-signel-rpc-dispatch-unknown-id-is-noop () - "Boundary: a result response with an unregistered id is a silent no-op: -neither receive nor error handler fires, and the handler map stays empty." - (test-signel-rpc--reset) - (let ((called nil)) - (cl-letf (((symbol-function 'signel--handle-error) - (lambda (&rest _) (setq called 'error))) - ((symbol-function 'signel--handle-receive) - (lambda (&rest _) (setq called 'receive)))) - (signel--dispatch '((jsonrpc . "2.0") (id . 99) (result . "anything")))) - (should-not called) - (should (zerop (hash-table-count signel--request-handler-map))))) - -(ert-deftest test-signel-rpc-dispatch-error-cleans-up-handler () - "Error: an error response with a registered id removes the handler without -firing the callback, leaving the map clean for a retry." - (test-signel-rpc--reset) - (let ((fired nil)) - (puthash 11 (lambda (&rest _) (setq fired t)) - signel--request-handler-map) - (cl-letf (((symbol-function 'signel--handle-error) (lambda (&rest _) nil))) - (signel--dispatch '((jsonrpc . "2.0") (id . 11) - (error . ((code . -1) (message . "boom")))))) - (should-not fired) - (should-not (gethash 11 signel--request-handler-map)))) - -(ert-deftest test-signel-rpc-send-rpc-registers-success-callback () - "Normal: passing a SUCCESS-CALLBACK to `signel--send-rpc' stores it under -the returned id so the matching response can route to it." - (test-signel-rpc--reset) - (let ((cb (lambda (_) 'ok)) - (sent nil)) - (cl-letf (((symbol-function 'get-process) (lambda (&rest _) 'fake-proc)) - ((symbol-function 'process-send-string) - (lambda (_ s) (setq sent s))) - ((symbol-function 'signel--log) (lambda (&rest _) nil))) - (let ((id (signel--send-rpc "listContacts" nil nil cb))) - (should (eq cb (gethash id signel--request-handler-map))) - (should (stringp sent)))))) - -(ert-deftest test-signel-rpc-stop-clears-handler-map () - "Normal (reconnect-invalidation): `signel-stop' clears the handler map so a -restart starts with no stale callbacks waiting for responses that will never -arrive." - (test-signel-rpc--reset) - (puthash 13 (lambda (&rest _) nil) signel--request-handler-map) - (cl-letf (((symbol-function 'get-process) (lambda (&rest _) nil))) - (signel-stop)) - (should (zerop (hash-table-count signel--request-handler-map)))) - -(provide 'test-signel-rpc-dispatch) -;;; test-signel-rpc-dispatch.el ends here diff --git a/tests/test-slack-config--notify.el b/tests/test-slack-config--notify.el new file mode 100644 index 00000000..d830ae29 --- /dev/null +++ b/tests/test-slack-config--notify.el @@ -0,0 +1,113 @@ +;;; test-slack-config--notify.el --- Slack notification hardening tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The config audit found `cj/slack-notify' missing signel's hardening: no +;; body truncation (giant toasts), no whitespace collapse, no sound gating, +;; and no `notifications-notify' fallback when the notify script is absent +;; (the raw `start-process' error was swallowed by the condition-case, so +;; the notification silently vanished). This mirrors signel's shape in +;; place; the shared cj/messenger-notify extraction belongs to the +;; messenger-unification task. +;; +;; The slack package's own predicates (`slack-im-p', `slack-message-minep', +;; `slack-message-mentioned-p') are package boundaries and are mocked; the +;; formatter and routing logic run real. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'slack-config) + +;;; ------------------------------ body formatter ----------------------------- + +(ert-deftest test-slack-config-format-notify-body-collapses-whitespace () + "Normal: whitespace runs (including newlines) become single spaces." + (should (equal (cj/slack--format-notify-body "a b\nc\t\td") + "a b c d"))) + +(ert-deftest test-slack-config-format-notify-body-truncates-long () + "Boundary: text over the max truncates to max length ending in an ellipsis." + (let ((long (make-string 500 ?x))) + (let ((formatted (cj/slack--format-notify-body long))) + (should (= (length formatted) cj/slack--notify-body-max)) + (should (string-suffix-p "…" formatted))))) + +(ert-deftest test-slack-config-format-notify-body-empty () + "Boundary: empty and whitespace-only input format to the empty string." + (should (equal (cj/slack--format-notify-body "") "")) + (should (equal (cj/slack--format-notify-body " \n\t ") ""))) + +;;; ----------------------------- delivery routing ---------------------------- + +(ert-deftest test-slack-config-send-notification-script-silent-by-default () + "Normal: with the notify script on PATH and sound off, --silent is passed." + (let ((argv nil) (cj/slack-notify-sound nil)) + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "notify") "/bin/notify"))) + ((symbol-function 'start-process) + (lambda (_name _buf &rest args) (setq argv args)))) + (cj/slack--send-notification "Slack: general" "hello")) + (should (equal argv '("/bin/notify" "info" "Slack: general" "hello" "--silent"))))) + +(ert-deftest test-slack-config-send-notification-sound-enabled () + "Boundary: with sound enabled, --silent is not passed." + (let ((argv nil) (cj/slack-notify-sound t)) + (cl-letf (((symbol-function 'executable-find) + (lambda (prog &rest _) (when (equal prog "notify") "/bin/notify"))) + ((symbol-function 'start-process) + (lambda (_name _buf &rest args) (setq argv args)))) + (cj/slack--send-notification "Slack: general" "hello")) + (should (equal argv '("/bin/notify" "info" "Slack: general" "hello"))))) + +(ert-deftest test-slack-config-send-notification-fallback-without-script () + "Error: with no notify script, delivery falls back to notifications-notify." + (let ((fallback nil)) + (cl-letf (((symbol-function 'executable-find) (lambda (&rest _) nil)) + ((symbol-function 'notifications-notify) + (lambda (&rest args) (setq fallback args)))) + (cj/slack--send-notification "Slack: general" "hello")) + (should (equal (plist-get fallback :title) "Slack: general")) + (should (equal (plist-get fallback :body) "hello")))) + +;;; --------------------------- predicate wiring ------------------------------ + +(defmacro test-slack-notify--with-message (minep im-p mentioned-p &rest body) + "Run BODY with the slack package predicates mocked to the given values. +Also mocks room/body accessors and captures delivery into `sent'." + (declare (indent 3)) + `(let ((sent nil)) + (cl-letf (((symbol-function 'slack-message-minep) (lambda (&rest _) ,minep)) + ((symbol-function 'slack-im-p) (lambda (&rest _) ,im-p)) + ((symbol-function 'slack-message-mentioned-p) (lambda (&rest _) ,mentioned-p)) + ((symbol-function 'slack-room-display-name) (lambda (&rest _) "general")) + ((symbol-function 'slack-message-body) (lambda (&rest _) "the message")) + ((symbol-function 'cj/slack--send-notification) + (lambda (title body) (setq sent (list title body))))) + (cj/slack-notify 'msg 'room 'team) + ,@body))) + +(ert-deftest test-slack-config-notify-dm-notifies () + "Normal: a DM from someone else raises a notification." + (test-slack-notify--with-message nil t nil + (should (equal sent '("Slack: general" "the message"))))) + +(ert-deftest test-slack-config-notify-mention-notifies () + "Normal: an @mention in a channel raises a notification." + (test-slack-notify--with-message nil nil t + (should (equal sent '("Slack: general" "the message"))))) + +(ert-deftest test-slack-config-notify-own-message-silent () + "Boundary: your own message never notifies, even in a DM." + (test-slack-notify--with-message t t t + (should-not sent))) + +(ert-deftest test-slack-config-notify-plain-channel-silent () + "Boundary: a channel message with no mention stays silent." + (test-slack-notify--with-message nil nil nil + (should-not sent))) + +(provide 'test-slack-config--notify) +;;; test-slack-config--notify.el ends here diff --git a/tests/test-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-auth-source-secret-value.el b/tests/test-system-lib-auth-source-secret-value.el index ec526cec..27a2696b 100644 --- a/tests/test-system-lib-auth-source-secret-value.el +++ b/tests/test-system-lib-auth-source-secret-value.el @@ -63,5 +63,44 @@ Captures the call args in `test-ass--args'." (test-ass--with-search (list (list :host "h")) (should (null (cj/auth-source-secret-value "h"))))) +;;; Error + +(ert-deftest test-auth-source-secret-value-loads-auth-source-when-absent () + "Error: with `auth-source-search' unavailable, the helper loads auth-source. + +Under `emacs --batch -Q' nothing else pulls auth-source in, so a helper +carrying only a `declare-function' dies with a void-function on the first +lookup. An interactive Emacs hides this completely -- something in init +always has auth-source loaded by the time anyone calls here -- which is why +it surfaced only on the batch calendar sync, and only on the machine whose +feeds resolve through `:secret-host' rather than an inline URL. + +The stubbed `require' installs the entry point the way loading auth-source.el +would, so the call can complete and the return value is checked too." + (let ((required nil)) + (cl-letf (((symbol-function 'auth-source-search) nil) + ((symbol-function 'require) + (lambda (feature &rest _) + (push feature required) + (fset 'auth-source-search + (lambda (&rest _) (list (list :secret "loaded")))) + feature))) + (should (equal "loaded" (cj/auth-source-secret-value "h"))) + (should (memq 'auth-source required))))) + +(ert-deftest test-auth-source-secret-value-does-not-reload-when-present () + "Error: an available `auth-source-search' is used as-is, never re-required. + +An unconditional `require' re-loads auth-source.el over whatever is in place, +replacing a caller's stub mid-call -- which sent a test that meant to fake the +lookup out to the real authinfo, where it hung for twelve seconds on gpg." + (let ((required nil)) + (cl-letf (((symbol-function 'require) + (lambda (feature &rest _) (push feature required) feature)) + ((symbol-function 'auth-source-search) + (lambda (&rest _) (list (list :secret "stubbed"))))) + (should (equal "stubbed" (cj/auth-source-secret-value "h"))) + (should-not (memq 'auth-source required))))) + (provide 'test-system-lib-auth-source-secret-value) ;;; test-system-lib-auth-source-secret-value.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-test-runner.el b/tests/test-test-runner.el index 0ff66f7f..6854b72e 100644 --- a/tests/test-test-runner.el +++ b/tests/test-test-runner.el @@ -152,6 +152,25 @@ FILES is an alist of relative test filenames to file contents." (should (eq (car result) 'not-in-testdir))) (test-testrunner-teardown)) +(ert-deftest test-testrunner-focus-add-file-shared-prefix-sibling-rejected () + "Boundary: a sibling directory sharing the test dir's name prefix is outside it. +`/tmp/x/tests-old/f.el' starts with `/tmp/x/tests' as a string, but it is not +in `/tmp/x/tests'. A raw `string-prefix-p' on the two truenames accepts it; +comparing against the directory with a trailing slash rejects it." + (test-testrunner-setup) + (let* ((testdir (file-truename test-testrunner--temp-dir)) + (sibling (concat (directory-file-name testdir) "-old")) + (filepath (expand-file-name "test-foo.el" sibling))) + (unwind-protect + (progn + (make-directory sibling t) + (with-temp-file filepath (insert ";; not in the test dir\n")) + (let ((result (cj/test--do-focus-add-file + filepath test-testrunner--temp-dir '()))) + (should (eq (car result) 'not-in-testdir)))) + (when (file-directory-p sibling) (delete-directory sibling t)))) + (test-testrunner-teardown)) + (ert-deftest test-testrunner-focus-add-file-already-focused () "Should detect already focused file." (test-testrunner-setup) diff --git a/tests/test-text-config.el b/tests/test-text-config.el index 96935e1b..82dfe05e 100644 --- a/tests/test-text-config.el +++ b/tests/test-text-config.el @@ -37,5 +37,18 @@ standard boundary check." (should (eq (cj/prettify-compose-block-markers-p start end "lambda") (prettify-symbols-default-compose-p start end "lambda")))))) +(ert-deftest test-text-config-edit-indirect-bound-on-reachable-key () + "Error/regression: edit-indirect-region is bound on M-I -- the event +Meta+Shift+i actually produces -- not the unreachable M-S-i, which no +keypress generates so it silently fell through to M-i tab-to-tab-stop." + (should (eq (key-binding (kbd "M-I")) #'edit-indirect-region)) + (should-not (eq (key-binding (kbd "M-S-i")) #'edit-indirect-region))) + +(ert-deftest test-text-config-accent-uses-completion-agnostic-backend () + "Regression: C-` invokes accent-menu, which reads through the minibuffer +and so survives a Company->Corfu migration, rather than accent-company, +whose company backend would break silently once Company is gone." + (should (eq (key-binding (kbd "C-`")) #'accent-menu))) + (provide 'test-text-config) ;;; test-text-config.el ends here diff --git a/tests/test-ui-theme-persistence.el b/tests/test-ui-theme-persistence.el index 02bb105a..250b606b 100644 --- a/tests/test-ui-theme-persistence.el +++ b/tests/test-ui-theme-persistence.el @@ -32,6 +32,19 @@ "modus-vivendi"))) (delete-file file)))) +(ert-deftest test-ui-theme-write-file-contents-creates-missing-parent-dir () + "Boundary: writing into a not-yet-existing directory creates it first. +On a fresh machine `persist/' does not exist, and `file-writable-p' returns nil +for a file inside a missing directory, so the write must create the parent." + (let* ((sandbox (make-temp-file "ui-theme-sandbox-" t)) + (file (expand-file-name "persist/emacs-theme" sandbox))) + (unwind-protect + (progn + (should-not (file-directory-p (file-name-directory file))) + (should (cj/theme-write-file-contents "modus-vivendi" file)) + (should (equal (cj/theme-read-file-contents file) "modus-vivendi"))) + (delete-directory sandbox t)))) + (ert-deftest test-ui-theme-write-file-contents-uses-write-region () "Theme persistence should write directly instead of visiting the file." (let ((file (make-temp-file "ui-theme-write-region-")) diff --git a/tests/test-undead-buffers-kill-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-undead-buffers-kill-other-window.el b/tests/test-undead-buffers-kill-other-window.el index e9371a0f..000ada9b 100644 --- a/tests/test-undead-buffers-kill-other-window.el +++ b/tests/test-undead-buffers-kill-other-window.el @@ -66,8 +66,9 @@ ;;; Boundary Cases -(ert-deftest test-kill-other-window-single-window-should-only-kill-buffer () - "With single window, should only kill the current buffer." +(ert-deftest test-kill-other-window-single-window-signals-no-other-window () + "Error: with a single window, signal `user-error' and kill nothing. +There is no other window, so acting would kill the buffer being viewed." (test-kill-other-window-setup) (unwind-protect (let ((buf (generate-new-buffer "*test-single-other*"))) @@ -75,9 +76,9 @@ (progn (switch-to-buffer buf) (should (one-window-p)) - (cj/kill-other-window) + (should-error (cj/kill-other-window) :type 'user-error) (should (one-window-p)) - (should-not (buffer-live-p buf))) + (should (buffer-live-p buf))) (when (buffer-live-p buf) (kill-buffer buf)))) (test-kill-other-window-teardown))) diff --git a/tests/test-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--build-video-command.el b/tests/test-video-audio-recording--build-video-command.el index 4f290978..1ffce95b 100644 --- a/tests/test-video-audio-recording--build-video-command.el +++ b/tests/test-video-audio-recording--build-video-command.el @@ -27,6 +27,14 @@ (should (string-match-p "-i pipe:0" cmd)) (should (string-match-p "-c:v copy" cmd)))))) +(ert-deftest test-video-audio-recording--build-video-command-normal-wayland-keeps-wf-recorder-stderr () + "Wayland command does not discard wf-recorder stderr, so a failed grab is diagnosable." + (let ((cj/recording-mic-boost 2.0) + (cj/recording-system-volume 1.0)) + (cl-letf (((symbol-function 'executable-find) (lambda (_prog &rest _) t))) + (let ((cmd (cj/recording--build-video-command "mic" "sys" "/tmp/out.mkv" t))) + (should-not (string-match-p "2>/dev/null" cmd)))))) + (ert-deftest test-video-audio-recording--build-video-command-normal-x11-uses-x11grab () "X11 command uses ffmpeg with x11grab, no wf-recorder." (let ((cj/recording-mic-boost 2.0) diff --git a/tests/test-video-audio-recording--keybindings.el b/tests/test-video-audio-recording--keybindings.el new file mode 100644 index 00000000..cdb6493a --- /dev/null +++ b/tests/test-video-audio-recording--keybindings.el @@ -0,0 +1,130 @@ +;;; test-video-audio-recording--keybindings.el --- recording toggle keybinding placement -*- lexical-binding: t; -*- + +;;; Commentary: +;; The two recording toggles get a fast chord alongside the C-; r prefix: F9 +;; starts/stops video, S-F9 starts/stops audio. +;; +;; Reaching them from inside an EAT buffer turns on which key categories each +;; input mode claims. Semi-char mode -- the default, and where agent buffers +;; sit -- is built from (:ascii :arrow :navigation) and never claims function +;; keys, so F9 already fell through to the global map there. Char mode adds +;; :function, binding f1 through f63 to `eat-self-input', and it is a minor +;; mode, so its map outranks `eat-mode-map'. The char-mode entries are the +;; load-bearing ones; the semi-char entry is belt-and-braces. +;; +;; :function claims only the unmodified keys, which is why getting this wrong +;; split the pair rather than breaking it outright: S-F9 toggled audio in a +;; char-mode buffer while F9 went to the program under the cursor. +;; +;; These tests require eat first so the module's `with-eval-after-load' fires. +;; The char-mode cases resolve through `key-binding' in a fixture that +;; reproduces minor-mode precedence, because reading a binding back out of the +;; map the module just wrote proves nothing about which map wins on a keypress. + +;;; Code: + +(require 'ert) +(require 'package) + +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'eat) +(require 'video-audio-recording) + +;;; Normal + +(ert-deftest test-video-audio-recording-f9-bound-globally () + "Normal: F9 toggles video recording, S-F9 toggles audio recording." + (should (eq (lookup-key (current-global-map) (kbd "<f9>")) + #'cj/video-recording-toggle)) + (should (eq (lookup-key (current-global-map) (kbd "S-<f9>")) + #'cj/audio-recording-toggle))) + +(ert-deftest test-video-audio-recording-f9-bound-in-eat-semi-char-mode-map () + "Normal: both chords are bound in `eat-semi-char-mode-map'. +Redundant rather than load-bearing: semi-char is built without :function, so a +function key already falls through to the global map. Asserted anyway so the +entry cannot be dropped silently while the comment explaining it stays." + (should (eq (keymap-lookup eat-semi-char-mode-map "<f9>") + #'cj/video-recording-toggle)) + (should (eq (keymap-lookup eat-semi-char-mode-map "S-<f9>") + #'cj/audio-recording-toggle))) + +(ert-deftest test-video-audio-recording-f9-bound-in-eat-mode-map () + "Normal: both chords are bound in `eat-mode-map', the major-mode map every +EAT buffer carries regardless of input mode." + (should (eq (keymap-lookup eat-mode-map "<f9>") + #'cj/video-recording-toggle)) + (should (eq (keymap-lookup eat-mode-map "S-<f9>") + #'cj/audio-recording-toggle))) + +(ert-deftest test-video-audio-recording-f9-bound-in-eat-char-mode-maps () + "Normal: both chords are bound in the two char-mode maps. +Char mode is built with EAT's :function category, which binds f1 through f63 +to `eat-self-input'. These entries are what override that." + (dolist (map (list eat-char-mode-map eat-eshell-char-mode-map)) + (should (eq (keymap-lookup map "<f9>") #'cj/video-recording-toggle)) + (should (eq (keymap-lookup map "S-<f9>") #'cj/audio-recording-toggle)))) + +;;; Boundary + +(ert-deftest test-video-audio-recording-f9-chords-are-distinct () + "Boundary: the shifted and unshifted chords resolve to different commands. +A copy-paste binding both to the same toggle would satisfy every +binding-is-present assertion above, so assert the difference directly." + (should-not (eq (lookup-key (current-global-map) (kbd "<f9>")) + (lookup-key (current-global-map) (kbd "S-<f9>"))))) + +(defun test-video-audio-recording--in-char-mode (body) + "Run BODY in a buffer wired the way a live EAT char-mode buffer is. +`eat--char-mode' is a minor mode, so its map is consulted ahead of the +major-mode map. Reproducing that ordering is the point: reading a binding +back out of the map the module just wrote proves nothing about which map wins +when a key is actually pressed." + (with-temp-buffer + (use-local-map eat-mode-map) + (let ((minor-mode-overriding-map-alist + (list (cons 'eat--char-mode eat-char-mode-map))) + (eat--char-mode t)) + (funcall body)))) + +(ert-deftest test-video-audio-recording-f9-resolves-in-char-mode () + "Boundary: both chords resolve to the toggles through the real precedence +chain in a char-mode buffer. Before this override F9 resolved to +`eat-self-input' and went to the program under the cursor, while S-F9 reached +Emacs — so the pair silently split, audio recording and video not." + (test-video-audio-recording--in-char-mode + (lambda () + (should (eq (key-binding (kbd "<f9>")) #'cj/video-recording-toggle)) + (should (eq (key-binding (kbd "S-<f9>")) #'cj/audio-recording-toggle))))) + +;;; Error + +(ert-deftest test-video-audio-recording-char-mode-fixture-really-is-char-mode () + "Error (positive control): the char-mode fixture genuinely puts EAT's map in +front. F8 sits in the same :function category as F9 and this module never +touches it, so it must still reach `eat-self-input'. If it resolves anywhere +else the fixture is inert, and the resolution test above would pass without +ever consulting `eat-char-mode-map' — which is precisely how the first cut of +this file missed that F9 was being swallowed there." + (test-video-audio-recording--in-char-mode + (lambda () + (should (eq (key-binding (kbd "<f8>")) #'eat-self-input))))) + +(ert-deftest test-video-audio-recording-f9-targets-are-commands () + "Error: a key bound to a non-interactive function fails at press time with a +`commandp' error rather than at load, so assert both targets are real commands." + (should (commandp (lookup-key (current-global-map) (kbd "<f9>")))) + (should (commandp (lookup-key (current-global-map) (kbd "S-<f9>"))))) + +(ert-deftest test-video-audio-recording-prefix-bindings-still-reachable () + "Error/regression (positive control): the fast chords must not disturb the +C-; r prefix path. Without this, deleting the prefix map outright would leave +every assertion above green." + (should (eq (keymap-lookup cj/record-map "v") #'cj/video-recording-toggle)) + (should (eq (keymap-lookup cj/record-map "a") #'cj/audio-recording-toggle)) + (should (eq (keymap-lookup cj/custom-keymap "r") cj/record-map))) + +(provide 'test-video-audio-recording--keybindings) +;;; test-video-audio-recording--keybindings.el ends here diff --git a/tests/test-video-audio-recording--start-race.el b/tests/test-video-audio-recording--start-race.el new file mode 100644 index 00000000..36ea8595 --- /dev/null +++ b/tests/test-video-audio-recording--start-race.el @@ -0,0 +1,56 @@ +;;; test-video-audio-recording--start-race.el --- start-race fix tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the wf-recorder start-race fix: the poll that waits for a dying +;; wf-recorder to release the compositor capture before launching a new one, and +;; the fail-fast timing predicate that tells a 0.5s failed start from a real +;; recording. The pgrep wrapper and the live start/stop wiring are exercised in +;; the daemon, not here; the poll is tested with an injected predicate so no real +;; process is needed. + +;;; Code: + +(require 'ert) + +;; Stub dependencies before loading the module. +(defvar cj/custom-keymap (make-sparse-keymap) + "Stub keymap for testing.") + +(require 'video-audio-recording) + +(declare-function cj/recording--start-failed-p "video-audio-recording-capture" (elapsed threshold)) +(declare-function cj/recording--wait-for-no-wf-recorder "video-audio-recording-capture" (timeout-secs &optional running-p)) + +;;; ------------------------- cj/recording--start-failed-p --------------------- + +(ert-deftest test-recording-start-failed-p-short-exit-is-failure () + "Normal: an exit well before the threshold is a failed start." + (should (cj/recording--start-failed-p 0.5 1.5))) + +(ert-deftest test-recording-start-failed-p-long-run-is-not-failure () + "Normal: a long-running recording that ends is not a failed start." + (should-not (cj/recording--start-failed-p 30.0 1.5))) + +(ert-deftest test-recording-start-failed-p-at-threshold-is-not-failure () + "Boundary: an exit exactly at the threshold is not counted as failed." + (should-not (cj/recording--start-failed-p 1.5 1.5))) + +;;; -------------------- cj/recording--wait-for-no-wf-recorder ------------------ + +(ert-deftest test-recording-wait-for-no-wf-recorder-clears () + "Normal: returns t once the injected predicate reports wf-recorder gone." + (let ((n 0)) + (should (cj/recording--wait-for-no-wf-recorder + 2.0 + (lambda () (setq n (1+ n)) (< n 3)))))) + +(ert-deftest test-recording-wait-for-no-wf-recorder-already-clear () + "Boundary: an already-clear predicate returns t immediately." + (should (cj/recording--wait-for-no-wf-recorder 2.0 (lambda () nil)))) + +(ert-deftest test-recording-wait-for-no-wf-recorder-times-out () + "Error: a predicate that never clears returns nil at the timeout." + (should-not (cj/recording--wait-for-no-wf-recorder 0.15 (lambda () t)))) + +(provide 'test-video-audio-recording--start-race) +;;; test-video-audio-recording--start-race.el ends here diff --git a/tests/test-video-audio-recording-group-devices-by-hardware.el b/tests/test-video-audio-recording-group-devices-by-hardware.el deleted file mode 100644 index 2be4982f..00000000 --- a/tests/test-video-audio-recording-group-devices-by-hardware.el +++ /dev/null @@ -1,194 +0,0 @@ -;;; test-video-audio-recording-group-devices-by-hardware.el --- Tests for cj/recording-group-devices-by-hardware -*- lexical-binding: t; -*- - -;;; Commentary: -;; Unit tests for cj/recording-group-devices-by-hardware function. -;; Tests grouping of audio sources by physical hardware device. -;; Critical test: Bluetooth MAC address normalization (colons vs underscores). -;; -;; This function is used by the quick setup command to automatically pair -;; microphone and monitor devices from the same hardware. - -;;; Code: - -(require 'ert) - -;; Stub dependencies before loading the module -(defvar cj/custom-keymap (make-sparse-keymap) - "Stub keymap for testing.") - -;; Now load the actual production module -(require 'video-audio-recording) - -;;; Test Fixtures Helper - -(defun test-load-fixture (filename) - "Load fixture file FILENAME from tests/fixtures directory." - (let ((fixture-path (expand-file-name - (concat "tests/fixtures/" filename) - user-emacs-directory))) - (with-temp-buffer - (insert-file-contents fixture-path) - (buffer-string)))) - -;;; Normal Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-all-types-grouped () - "Test grouping of all three device types (built-in, USB, Bluetooth). -This is the key test validating the complete grouping logic." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (= 3 (length result))) - ;; Check that we have all three device types - (let ((names (mapcar #'car result))) - (should (member "Built-in Audio" names)) - (should (member "Bluetooth Headset" names)) - (should (member "Jabra SPEAK 510 USB" names))) - ;; Verify each device has both mic and monitor - (dolist (device result) - (should (stringp (car device))) ; friendly name - (should (stringp (cadr device))) ; mic device - (should (stringp (cddr device))) ; monitor device - (should-not (string-suffix-p ".monitor" (cadr device))) ; mic not monitor - (should (string-suffix-p ".monitor" (cddr device)))))))) ; monitor has suffix - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-built-in-paired () - "Test that built-in laptop audio devices are correctly paired." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (built-in (assoc "Built-in Audio" result))) - (should built-in) - (should (string-match-p "pci-0000_00_1f" (cadr built-in))) - (should (string-match-p "pci-0000_00_1f" (cddr built-in))) - (should (equal "alsa_input.pci-0000_00_1f.3.analog-stereo" (cadr built-in))) - (should (equal "alsa_output.pci-0000_00_1f.3.analog-stereo.monitor" (cddr built-in))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-usb-paired () - "Test that USB devices (Jabra) are correctly paired." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (jabra (assoc "Jabra SPEAK 510 USB" result))) - (should jabra) - (should (string-match-p "Jabra" (cadr jabra))) - (should (string-match-p "Jabra" (cddr jabra))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-normal-bluetooth-paired () - "Test that Bluetooth devices are correctly paired. -CRITICAL: Tests MAC address normalization (colons in input, underscores in output)." - (let ((output (test-load-fixture "pactl-output-normal.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let* ((result (cj/recording-group-devices-by-hardware)) - (bluetooth (assoc "Bluetooth Headset" result))) - (should bluetooth) - ;; Input has colons: bluez_input.00:1B:66:C0:91:6D - (should (equal "bluez_input.00:1B:66:C0:91:6D" (cadr bluetooth))) - ;; Output has underscores: bluez_output.00_1B_66_C0_91_6D.1.monitor - ;; But they should still be grouped together (MAC address normalized) - (should (equal "bluez_output.00_1B_66_C0_91_6D.1.monitor" (cddr bluetooth))))))) - -;;; Boundary Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-empty-returns-empty () - "Test that empty pactl output returns empty list." - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) ""))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-only-inputs-returns-empty () - "Test that only input devices (no monitors) returns empty list. -Devices must have BOTH mic and monitor to be included." - (let ((output (test-load-fixture "pactl-output-inputs-only.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-only-monitors-returns-empty () - "Test that only monitor devices (no inputs) returns empty list." - (let ((output (test-load-fixture "pactl-output-monitors-only.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-single-complete-device () - "Test that single device with both mic and monitor is returned." - (let ((output "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n")) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - (should (equal "Built-in Audio" (caar result))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-boundary-mixed-complete-incomplete () - "Test that only devices with BOTH mic and monitor are included. -Incomplete devices (only mic or only monitor) are filtered out." - (let ((output (concat - ;; Complete device (built-in) - "50\talsa_input.pci-0000_00_1f.3.analog-stereo\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - "49\talsa_output.pci-0000_00_1f.3.analog-stereo.monitor\tPipeWire\ts32le 2ch 48000Hz\tSUSPENDED\n" - ;; Incomplete: USB mic with no monitor - "100\talsa_input.usb-device.mono-fallback\tPipeWire\ts16le 1ch 16000Hz\tSUSPENDED\n" - ;; Incomplete: Bluetooth monitor with no mic - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - ;; Only the complete built-in device should be returned - (should (= 1 (length result))) - (should (equal "Built-in Audio" (caar result))))))) - -;;; Error Cases - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-malformed-output-returns-empty () - "Test that malformed pactl output returns empty list." - (let ((output (test-load-fixture "pactl-output-malformed.txt"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (listp result)) - (should (null result)))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-unknown-device-type () - "Test that unknown device types get generic 'USB Audio Device' name." - (let ((output (concat - "100\talsa_input.usb-unknown_device-00.analog-stereo\tPipeWire\ts16le 2ch 16000Hz\tSUSPENDED\n" - "99\talsa_output.usb-unknown_device-00.analog-stereo.monitor\tPipeWire\ts16le 2ch 48000Hz\tSUSPENDED\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - ;; Should get generic USB name (not matching Jabra pattern) - (should (equal "USB Audio Device" (caar result))))))) - -(ert-deftest test-video-audio-recording-group-devices-by-hardware-error-bluetooth-mac-case-variations () - "Test that Bluetooth MAC addresses work with different formatting. -Tests the normalization logic handles various MAC address formats." - (let ((output (concat - ;; Input with colons (typical) - "79\tbluez_input.AA:BB:CC:DD:EE:FF\tPipeWire\tfloat32le 1ch 48000Hz\tSUSPENDED\n" - ;; Output with underscores (typical) - "81\tbluez_output.AA_BB_CC_DD_EE_FF.1.monitor\tPipeWire\ts24le 2ch 48000Hz\tRUNNING\n"))) - (cl-letf (((symbol-function 'shell-command-to-string) - (lambda (_cmd) output))) - (let ((result (cj/recording-group-devices-by-hardware))) - (should (= 1 (length result))) - (should (equal "Bluetooth Headset" (caar result))) - ;; Verify both devices paired despite different MAC formats - (let ((device (car result))) - (should (string-match-p "AA:BB:CC" (cadr device))) - (should (string-match-p "AA_BB_CC" (cddr device)))))))) - -(provide 'test-video-audio-recording-group-devices-by-hardware) -;;; test-video-audio-recording-group-devices-by-hardware.el ends here diff --git a/tests/test-video-audio-recording-process-sentinel.el b/tests/test-video-audio-recording-process-sentinel.el index 92fb3f0d..d733e46f 100644 --- a/tests/test-video-audio-recording-process-sentinel.el +++ b/tests/test-video-audio-recording-process-sentinel.el @@ -190,5 +190,157 @@ (should (null cj/audio-recording-ffmpeg-process)))) (test-sentinel-teardown))) +;;; Failed-Start Stub Deletion +;; +;; On Wayland a wf-recorder that fails to grab the compositor capture +;; still writes a ~500KB, ~0.5s stub .mkv before dying. The sentinel +;; detects the failed start (exit sooner than +;; `cj/recording-start-fail-threshold' without a user stop); these tests +;; pin that it also deletes the stub file stamped on the process as the +;; `cj-output-file' property — and that normal stops and user stops +;; never delete anything. + +(defun test-sentinel--make-exited-process () + "Return a real process that has already exited. +Drives the sentinel with a genuinely dead process so `process-status' +and the process plist behave for real instead of through mocks." + (let ((proc (make-process :name "test-sentinel-exited" + :command '("true") + :sentinel #'ignore))) + (while (process-live-p proc) + (accept-process-output proc 0.05)) + proc)) + +(defun test-sentinel--make-stub-file () + "Create and return a temp file standing in for the stub .mkv." + (make-temp-file "test-sentinel-stub-" nil ".mkv" "stub-content")) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-failed-start-deletes-stub () + "Normal: a failed video start deletes the stub output file." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file))) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + ;; Exited immediately after its start time — a failed start. + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-output-file stub) + (cj/recording-process-sentinel proc "exited abnormally\n") + (should-not (file-exists-p stub))) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-failed-start-still-messages () + "Normal: the failed-start branch still reports the failure to the user." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file)) + (failure-messaged nil)) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-output-file stub) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) + (let ((msg (apply #'format fmt args))) + (when (string-match-p "failed to start" msg) + (setq failure-messaged t)))))) + (cj/recording-process-sentinel proc "exited abnormally\n")) + (should failure-messaged)) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-long-run-keeps-file () + "Normal: a recording that ran past the threshold keeps its output file." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file))) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + ;; Ran well past the fail threshold — a real recording. + (process-put proc 'cj-start-time + (- (float-time) + (* 10 cj/recording-start-fail-threshold))) + (process-put proc 'cj-output-file stub) + (cj/recording-process-sentinel proc "finished\n") + (should (file-exists-p stub))) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-boundary-user-stop-keeps-file () + "Boundary: a quick user stop (cj-stopping) never deletes the file." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process)) + (stub (test-sentinel--make-stub-file))) + (unwind-protect + (progn + (setq cj/video-recording-ffmpeg-process proc) + ;; Quick exit, but the user asked for it. + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-stopping t) + (process-put proc 'cj-output-file stub) + (cj/recording-process-sentinel proc "finished\n") + (should (file-exists-p stub))) + (when (file-exists-p stub) (delete-file stub)))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-boundary-missing-stub-no-error () + "Boundary: failed start whose stub never hit disk signals no error." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process))) + (setq cj/video-recording-ffmpeg-process proc) + (process-put proc 'cj-start-time (float-time)) + (process-put proc 'cj-output-file "/nonexistent/dir/never-written.mkv") + ;; Must not signal even though the file is absent. + (cj/recording-process-sentinel proc "exited abnormally\n") + (should (null cj/video-recording-ffmpeg-process))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-error-nil-output-property-no-error () + "Error: failed start with no cj-output-file property signals no error. +Covers processes started before the property existed (a live daemon +mid-upgrade) — the sentinel degrades to the old message-only path." + (test-sentinel-setup) + (unwind-protect + (let ((proc (test-sentinel--make-exited-process))) + (setq cj/video-recording-ffmpeg-process proc) + (process-put proc 'cj-start-time (float-time)) + ;; No cj-output-file property at all. + (cj/recording-process-sentinel proc "exited abnormally\n") + (should (null cj/video-recording-ffmpeg-process))) + (test-sentinel-teardown))) + +(ert-deftest test-video-audio-recording-process-sentinel-normal-start-stamps-output-file () + "Normal: `cj/ffmpeg-record-video' stamps cj-output-file on the process." + (test-sentinel-setup) + (unwind-protect + (let ((cj/recording-mic-device "test-mic-device") + (cj/recording-system-device "test-monitor-device") + (cj/recording-mic-boost 2.0) + (cj/recording-system-volume 1.0)) + (cl-letf (((symbol-function 'cj/recording--wayland-p) (lambda () nil)) + ((symbol-function 'cj/recording--validate-system-audio) + (lambda () nil)) + ((symbol-function 'start-process-shell-command) + (lambda (_name _buffer _command) + (make-process :name "fake-video" :command '("sleep" "1000"))))) + (cj/ffmpeg-record-video "/tmp/video-recordings/") + (let ((output-file (process-get cj/video-recording-ffmpeg-process + 'cj-output-file))) + (should (stringp output-file)) + (should (string-suffix-p ".mkv" output-file)) + (should (string-prefix-p "/tmp/video-recordings/" output-file)))) + (when cj/video-recording-ffmpeg-process + (ignore-errors (delete-process cj/video-recording-ffmpeg-process)))) + (test-sentinel-teardown))) + (provide 'test-video-audio-recording-process-sentinel) ;;; test-video-audio-recording-process-sentinel.el ends here diff --git a/tests/test-wrap-up--bury-buffers.el b/tests/test-wrap-up--bury-buffers.el new file mode 100644 index 00000000..00df69c7 --- /dev/null +++ b/tests/test-wrap-up--bury-buffers.el @@ -0,0 +1,96 @@ +;;; test-wrap-up--bury-buffers.el --- Tests for cj/bury-buffers -*- lexical-binding: t; -*- + +;;; Commentary: +;; Characterization tests for cj/bury-buffers, which buries the noisy +;; compile-and-shell buffers at the end of startup. +;; +;; Written to pin the buried set while a dead clause was removed. The function +;; tested `(derived-mode-p 'elisp-compile-mode)', and no such mode exists in +;; Emacs -- the real one is `emacs-lisp-compilation-mode', which derives from +;; `compilation-mode' and so was already matched by the clause above it. The +;; clause could never be true, and removing it must not change which buffers +;; get buried. These tests are what makes that claim checkable. +;; +;; Test organization: +;; - Normal Cases: each buried mode is buried; byte-compilation output included +;; - Boundary Cases: an ordinary buffer is left alone; an empty buffer list +;; - Error Cases: a killed buffer in the list does not break the sweep +;; +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'wrap-up) + +;; Required explicitly so each test stands alone. Without these the +;; comint-mode test passed only because ERT runs tests in alphabetical order +;; and an earlier test loaded `compile', which pulls in comint -- so renaming +;; or running that test by itself made it fail with void-function comint-mode. +(require 'comint) +(require 'bytecomp) + +(defmacro test-wrap-up--with-mode-buffer (mode &rest body) + "Create a buffer in MODE, bind it to `buf', run BODY, then kill it." + (declare (indent 1)) + `(let ((buf (generate-new-buffer "*test-bury*"))) + (unwind-protect + (progn + (with-current-buffer buf (funcall ,mode)) + ,@body) + (kill-buffer buf)))) + +;;; Normal Cases + +(ert-deftest test-wrap-up-bury-buffers-buries-compilation () + "Normal: a compilation-mode buffer is buried." + (test-wrap-up--with-mode-buffer #'compilation-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-buries-byte-compilation-output () + "Normal: the real byte-compilation mode is buried. +`emacs-lisp-compilation-mode' derives from `compilation-mode', which is +why the never-matching elisp-compile-mode clause was redundant." + (should (eq 'compilation-mode + (get 'emacs-lisp-compilation-mode 'derived-mode-parent))) + (test-wrap-up--with-mode-buffer #'emacs-lisp-compilation-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-buries-comint () + "Normal: a comint-mode buffer is buried." + (test-wrap-up--with-mode-buffer #'comint-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should-not (eq buf (car (buffer-list)))))) + +;;; Boundary Cases + +(ert-deftest test-wrap-up-bury-buffers-leaves-ordinary-buffer () + "Boundary: a fundamental-mode buffer is not buried." + (test-wrap-up--with-mode-buffer #'fundamental-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should (eq buf (car (buffer-list)))))) + +(ert-deftest test-wrap-up-bury-buffers-leaves-text-buffer () + "Boundary: an ordinary text-mode buffer is not buried." + (test-wrap-up--with-mode-buffer #'text-mode + (switch-to-buffer buf) + (cj/bury-buffers) + (should (eq buf (car (buffer-list)))))) + +;;; Error Cases + +(ert-deftest test-wrap-up-bury-buffers-survives-dead-mode-name () + "Error: the sweep completes even though elisp-compile-mode does not exist. +The removed clause named a mode Emacs has never defined; this pins that +the function still runs cleanly with no such mode anywhere." + (should-not (fboundp 'elisp-compile-mode)) + (should-not (get 'elisp-compile-mode 'derived-mode-parent)) + (cj/bury-buffers)) + +(provide 'test-wrap-up--bury-buffers) +;;; test-wrap-up--bury-buffers.el ends here 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." |