diff options
Diffstat (limited to 'tests')
32 files changed, 2515 insertions, 139 deletions
diff --git a/tests/test-agenda-query--render.el b/tests/test-agenda-query--render.el index 1f7232f2..da5c3f60 100644 --- a/tests/test-agenda-query--render.el +++ b/tests/test-agenda-query--render.el @@ -26,6 +26,9 @@ (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." @@ -136,10 +139,50 @@ 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." + ;; No priority cookie in this fixture. org 9.8 (Emacs 31.1) parses the + ;; cookie with `org-priority-regexp' under `looking-at', and that regexp's + ;; lazy `.*?' prefix swallows everything between the stars and the cookie, + ;; unknown keyword included. A cookie here would test org's bug rather than + ;; the vocabulary gap this test pins. + (let ((org-todo-keywords '((sequence "TODO" "|" "DONE")))) + (test-aq-render--with-agenda-file + "* DOING Justin Johns advisor projects\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (let ((row (car rows))) + (should (string-prefix-p "DOING" (alist-get 't row))) + (should-not (equal "DOING" (alist-get 'keyword row))))))) + ;;; ---------- the cache writer ---------- (ert-deftest test-agenda-render-normal-cache-update-writes-today () - "Normal: the cache writer covers the whole local day and creates its dir. + "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 @@ -161,19 +204,23 @@ or the next 24 from now, would still produce a plausible-looking file." (cj/agenda-render-cache-update))) (should (file-exists-p cj/agenda-render-cache-file)) (let* ((window (car windows)) - (d (decode-time (car window)))) + (start (decode-time (car window))) + (now (decode-time))) ;; Opens at local midnight... - (should (= 0 (nth 2 d))) - (should (= 0 (nth 1 d))) - (should (= 0 (nth 0 d))) - ;; ...and closes one second before the next. + (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) - (1- (cj/--agenda-query-epoch - 0 0 0 (1+ (nth 3 d)) (nth 4 d) (nth 5 d))))) - ;; It is today's day, not an arbitrary one. - (should (equal (list (nth 3 d) (nth 4 d) (nth 5 d)) - (let ((now (decode-time))) - (list (nth 3 now) (nth 4 now) (nth 5 now))))))) + (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 () 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-bootstrap-packages.bats b/tests/test-bootstrap-packages.bats new file mode 100644 index 00000000..7e511152 --- /dev/null +++ b/tests/test-bootstrap-packages.bats @@ -0,0 +1,142 @@ +#!/usr/bin/env bats +# Tests for scripts/bootstrap-packages.sh — the headless package installer. +# +# The elisp tests cover what happens inside one Emacs. What only a shell test +# can cover is the pass loop: whether a run that reports packages still missing +# gets another pass, whether a run that converges stops early, and whether a +# broken init breaks out instead of burning every pass on the same failure. +# +# Every test drives a fake emacs whose exit statuses are scripted, so no test +# touches the network, the real elpa directory, or a real Emacs. The script +# honours $EMACS, which is the seam these hang on. + +setup() { + SCRIPT="${BATS_TEST_DIRNAME}/../scripts/bootstrap-packages.sh" + BIN="${BATS_TEST_TMPDIR}/bin" + COUNTER="${BATS_TEST_TMPDIR}/attempts" + mkdir -p "$BIN" + echo 0 >"$COUNTER" + export BOOTSTRAP_PASSES=3 + export BOOTSTRAP_TIMEOUT=30 + # Point the script at a scratch config dir rather than the real checkout, so + # the byte-compiled-modules check reads fixture state instead of whatever + # this working tree happens to have compiled. + export BOOTSTRAP_DIR="${BATS_TEST_TMPDIR}/emacsd" + mkdir -p "$BOOTSTRAP_DIR/modules" +} + +# Write a fake emacs that exits with the given statuses in order, repeating the +# last one once the list runs out. Status 1 also prints the "still missing" +# line the real cj/package-bootstrap-batch prints, so the script's grep is +# exercised rather than assumed. +fake_emacs() { + { + echo '#!/usr/bin/env bash' + echo "n=\$(cat '$COUNTER')" + echo "n=\$((n + 1))" + echo "echo \$n >'$COUNTER'" + echo "statuses=($*)" + echo 'idx=$((n - 1))' + echo 'last=$((${#statuses[@]} - 1))' + echo '[ $idx -gt $last ] && idx=$last' + echo 'status=${statuses[$idx]}' + echo '[ "$status" -eq 1 ] && echo "package-bootstrap: 2 missing: foo bar"' + echo 'exit $status' + } >"$BIN/emacs" + chmod +x "$BIN/emacs" + export EMACS="$BIN/emacs" +} + +attempts() { cat "$COUNTER"; } + +@test "normal: a clean first pass succeeds and stops there" { + fake_emacs 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 1 ] + [[ "$output" == *"every package is installed"* ]] +} + +@test "normal: a pass reporting missing packages is retried until it converges" { + fake_emacs 1 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 2 ] + [[ "$output" == *"2 missing: foo bar"* ]] +} + +@test "error: packages that never install exhaust the passes and fail" { + fake_emacs 1 + run bash "$SCRIPT" + [ "$status" -eq 1 ] + [ "$(attempts)" -eq 3 ] + [[ "$output" == *"FAILED"* ]] +} + +@test "error: exit 1 without a missing-packages line is not blamed on packages" { + # The fake exits 1 silently, which is any other failure, not a short install. + { + echo '#!/usr/bin/env bash' + echo "n=\$(cat '$COUNTER'); echo \$((n + 1)) >'$COUNTER'" + echo 'exit 1' + } >"$BIN/emacs" + chmod +x "$BIN/emacs" + export EMACS="$BIN/emacs" + run bash "$SCRIPT" + [ "$status" -eq 1 ] + [ "$(attempts)" -eq 1 ] + [[ "$output" == *"without reporting missing packages"* ]] +} + +@test "error: a broken init breaks out instead of burning every pass" { + fake_emacs 255 + run bash "$SCRIPT" + [ "$status" -eq 255 ] + [ "$(attempts)" -eq 1 ] + [[ "$output" == *"failed to load init"* ]] +} + +@test "boundary: a timed-out pass is reported and still retried" { + fake_emacs 124 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 2 ] + [[ "$output" == *"timeout"* ]] +} + +@test "boundary: the pass ceiling is honoured" { + export BOOTSTRAP_PASSES=1 + fake_emacs 1 + run bash "$SCRIPT" + [ "$status" -eq 1 ] + [ "$(attempts)" -eq 1 ] +} + +@test "error: a byte-compiled tree is refused rather than passed vacuously" { + touch "$BOOTSTRAP_DIR/modules/foo.elc" + fake_emacs 0 + run bash "$SCRIPT" + [ "$status" -eq 2 ] + [ "$(attempts)" -eq 0 ] + [[ "$output" == *"REFUSING"* ]] + [[ "$output" == *"clean-compiled"* ]] + [[ "$output" != *"every package is installed"* ]] +} + +@test "boundary: a zero pass ceiling fails cleanly without a tail error" { + export BOOTSTRAP_PASSES=0 + fake_emacs 0 + run bash "$SCRIPT" + [ "$status" -ne 0 ] + [ "$(attempts)" -eq 0 ] + [[ "$output" != *"cannot open"* ]] + [[ "$output" == *"FAILED after 0 pass"* ]] +} + +@test "boundary: recovery on the final allowed pass still succeeds" { + export BOOTSTRAP_PASSES=3 + fake_emacs 1 1 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 3 ] +} 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--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-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-calibredb-epub-config.el b/tests/test-calibredb-epub-config.el index 7afc58f3..0e430a4e 100644 --- a/tests/test-calibredb-epub-config.el +++ b/tests/test-calibredb-epub-config.el @@ -16,6 +16,11 @@ (package-initialize) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'calibredb-epub-config) +;; Load calibredb before any test stubs its functions with `cl-letf'. The +;; module's jump path calls `(require 'calibredb)' inside the body; if the +;; package is still an autoload at that point, the real `defun' lands on top of +;; the stub and the test runs the real command against the real library. +(require 'calibredb) (require 'nov nil t) ; for the nov-mode-map keybinding test; harmless if absent (declare-function cj/nov--text-width "calibredb-epub-config" (total-cols)) diff --git a/tests/test-config-utilities--compile-this-elisp-buffer.el b/tests/test-config-utilities--compile-this-elisp-buffer.el index a06440ab..f1a442b4 100644 --- a/tests/test-config-utilities--compile-this-elisp-buffer.el +++ b/tests/test-config-utilities--compile-this-elisp-buffer.el @@ -1,10 +1,14 @@ ;;; test-config-utilities--compile-this-elisp-buffer.el --- Tests for cj/compile-this-elisp-buffer -*- lexical-binding: t; -*- ;;; Commentary: -;; Tests for `cj/compile-this-elisp-buffer'. The function dispatches -;; among native-compile-async, native-compile (sync), and -;; byte-compile-file based on which is fboundp. Tests force each -;; branch by mocking fboundp at the boundary. +;; Tests for `cj/compile-this-elisp-buffer' and its helper +;; `cj/--compile-elisp-file'. The helper dispatches among +;; native-compile-async, native-compile (sync), and byte-compile-file based +;; on an AVAILABLE-P predicate that defaults to `fboundp'. Tests force each +;; branch by passing the predicate, never by redefining `fboundp': an `fset' +;; on that subr autoloads comp-run, which requires bytecomp, whose `defun' of +;; `byte-compile-file' replaces any test double installed earlier in the same +;; `cl-letf' (Emacs 30.2 hid this because ert happened to preload bytecomp). ;;; Code: @@ -14,6 +18,10 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'config-utilities) +(defun test-config-utilities--available (&rest syms) + "Return a predicate that reports only SYMS as available compilers." + (lambda (sym) (memq sym syms))) + (defmacro test-config-utilities--with-elisp-buffer (path &rest body) "Run BODY in a temp buffer visiting PATH (a .el file path). Skips the interactive `save-buffer' so tests stay free of disk side @@ -24,72 +32,108 @@ effects." (cl-letf (((symbol-function 'save-buffer) (lambda (&rest _) nil))) ,@body))) +;; -- the interactive wrapper ------------------------------------------------- + (ert-deftest test-config-utilities-compile-buffer-not-elisp-raises () "Error: a buffer whose file isn't .el raises `user-error'." (test-config-utilities--with-elisp-buffer "/tmp/not-elisp.txt" (should-error (cj/compile-this-elisp-buffer) :type 'user-error))) -(ert-deftest test-config-utilities-compile-buffer-no-buffer-file-name-raises () - "Error: a buffer with no `buffer-file-name' raises `user-error'." +(ert-deftest test-config-utilities-compile-buffer-no-file-raises () + "Boundary: a buffer visiting no file raises `user-error' rather than +passing nil to the compiler." (with-temp-buffer - (setq buffer-file-name nil) (should-error (cj/compile-this-elisp-buffer) :type 'user-error))) +(ert-deftest test-config-utilities-compile-buffer-saves-then-delegates () + "Normal: the wrapper saves the buffer and hands its file to the helper." + (let (saved compiled) + (with-temp-buffer + (setq buffer-file-name "/tmp/some.el") + (cl-letf (((symbol-function 'save-buffer) (lambda (&rest _) (setq saved t))) + ((symbol-function 'cj/--compile-elisp-file) + (lambda (file &optional _) (setq compiled file)))) + (cj/compile-this-elisp-buffer))) + (should saved) + (should (equal compiled "/tmp/some.el")))) + +;; -- the helper's dispatch --------------------------------------------------- + (ert-deftest test-config-utilities-compile-buffer-prefers-native-async () "Normal: `native-compile-async' is preferred when available." (let (called-with) - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) - (memq sym '(native-compile-async native-compile byte-compile-file)))) - ((symbol-function 'native-compile-async) - (lambda (file) (setq called-with file))) - ((symbol-function 'native-compile) - (lambda (_) (error "should not call sync native-compile"))) - ((symbol-function 'byte-compile-file) - (lambda (&rest _) (error "should not call byte-compile-file")))) - (cj/compile-this-elisp-buffer) - (should (equal called-with "/tmp/some.el")))))) + (cl-letf (((symbol-function 'native-compile-async) + (lambda (file) (setq called-with file))) + ((symbol-function 'native-compile) + (lambda (_) (error "should not call sync native-compile"))) + ((symbol-function 'byte-compile-file) + (lambda (&rest _) (error "should not call byte-compile-file")))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'native-compile-async 'native-compile + 'byte-compile-file)) + (should (equal called-with "/tmp/some.el"))))) (ert-deftest test-config-utilities-compile-buffer-falls-back-to-sync-native () "Normal: `native-compile' is used when async isn't available." (let (called-with) - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) (memq sym '(native-compile byte-compile-file)))) - ((symbol-function 'native-compile) - (lambda (file) (setq called-with file))) - ((symbol-function 'byte-compile-file) - (lambda (&rest _) (error "should not call byte-compile-file")))) - (cj/compile-this-elisp-buffer) - (should (equal called-with "/tmp/some.el")))))) + (cl-letf (((symbol-function 'native-compile) + (lambda (file) (setq called-with file))) + ((symbol-function 'byte-compile-file) + (lambda (&rest _) (error "should not call byte-compile-file")))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'native-compile 'byte-compile-file)) + (should (equal called-with "/tmp/some.el"))))) (ert-deftest test-config-utilities-compile-buffer-falls-back-to-byte-compile () "Normal: `byte-compile-file' is used when neither native option is available." (let (called-with) - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) (eq sym 'byte-compile-file))) - ((symbol-function 'byte-compile-file) - (lambda (file &rest _) (setq called-with file) "/tmp/some.elc"))) - (cj/compile-this-elisp-buffer) - (should (equal called-with "/tmp/some.el")))))) + (cl-letf (((symbol-function 'byte-compile-file) + (lambda (file &rest _) (setq called-with file) "/tmp/some.elc"))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'byte-compile-file)) + (should (equal called-with "/tmp/some.el"))))) + +(ert-deftest test-config-utilities-compile-buffer-reports-when-nothing-available () + "Boundary: with no compiler available the helper only messages, calling none." + (let (captured) + (cl-letf (((symbol-function 'native-compile-async) + (lambda (&rest _) (error "should not call native-compile-async"))) + ((symbol-function 'native-compile) + (lambda (&rest _) (error "should not call native-compile"))) + ((symbol-function 'byte-compile-file) + (lambda (&rest _) (error "should not call byte-compile-file"))) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--compile-elisp-file "/tmp/some.el" (test-config-utilities--available))) + (should (string-match-p "No compilation available" captured)))) (ert-deftest test-config-utilities-compile-buffer-handles-sync-native-error () "Error: a sync `native-compile' that signals is caught and reported. -Asserts no error escapes by running the function and checking that the +Asserts no error escapes by running the helper and checking that the message captured contains the failure prefix." - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (let (captured) - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) (memq sym '(native-compile byte-compile-file)))) - ((symbol-function 'native-compile) - (lambda (_) (error "boom"))) - ((symbol-function 'message) - (lambda (fmt &rest args) - (setq captured (apply #'format fmt args))))) - (cj/compile-this-elisp-buffer)) - (should (string-match-p "Native compile failed" captured))))) + (let (captured) + (cl-letf (((symbol-function 'native-compile) + (lambda (_) (error "boom"))) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'native-compile 'byte-compile-file))) + (should (string-match-p "Native compile failed" captured)))) + +(ert-deftest test-config-utilities-compile-buffer-default-predicate-is-fboundp () + "Normal: with no predicate the helper consults `fboundp', so on a real +Emacs it reaches whichever compiler exists rather than the no-compiler +message." + (let (captured) + (cl-letf (((symbol-function 'native-compile-async) (lambda (&rest _) nil)) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--compile-elisp-file "/tmp/some.el")) + (should (string-match-p "Queued native compilation" captured)))) (provide 'test-config-utilities--compile-this-elisp-buffer) ;;; test-config-utilities--compile-this-elisp-buffer.el ends here 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-google-keep-config--local-config.el b/tests/test-google-keep-config--local-config.el new file mode 100644 index 00000000..18769c5a --- /dev/null +++ b/tests/test-google-keep-config--local-config.el @@ -0,0 +1,52 @@ +;;; test-google-keep-config--local-config.el --- Tests for the Keep machine-local config loader -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for cj/keep--load-local-config, the loader for the gitignored +;; machine-local google-keep.local.el (venv interpreter path, account email) — +;; the same shape calendar-sync uses for calendar-sync.local.el. + +;;; Code: + +(require 'ert) +(require 'google-keep-config) + +(ert-deftest test-google-keep-local-config-loads-readable-file () + "Normal: a readable local config file is loaded and its settings apply." + (let ((file (make-temp-file "keep-local-" nil ".el"))) + (unwind-protect + (progn + (with-temp-file file + (insert "(setq test-google-keep--local-marker 'loaded)")) + (defvar test-google-keep--local-marker nil) + (setq test-google-keep--local-marker nil) + (let ((cj/keep-local-config-file file)) + (should (cj/keep--load-local-config)) + (should (eq test-google-keep--local-marker 'loaded)))) + (delete-file file)))) + +(ert-deftest test-google-keep-local-config-missing-file-is-quiet () + "Boundary: an absent local config file is a silent no-op, no error." + (let ((cj/keep-local-config-file "/nonexistent/google-keep.local.el")) + (should-not (cj/keep--load-local-config)))) + +(ert-deftest test-google-keep-local-config-broken-file-does-not-signal () + "Error: a local config file with a broken form is caught and reported, +never propagated as a load-time error." + (let ((file (make-temp-file "keep-local-broken-" nil ".el")) + (messages nil)) + (unwind-protect + (progn + (with-temp-file file + (insert "(error \"deliberately broken local config\")")) + (let ((cj/keep-local-config-file file)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) + (push (apply #'format fmt args) messages) + nil))) + (should-not (cj/keep--load-local-config))) + (should (seq-find (lambda (m) (string-match-p "google-keep.*local config" m)) + messages)))) + (delete-file file)))) + +(provide 'test-google-keep-config--local-config) +;;; test-google-keep-config--local-config.el ends here diff --git a/tests/test-init-defer-games.el b/tests/test-init-defer-games.el index f3ec94de..4f349908 100644 --- a/tests/test-init-defer-games.el +++ b/tests/test-init-defer-games.el @@ -42,5 +42,36 @@ load failed to define malyon." (should (featurep 'games-config)) (should (equal malyon-stories-directory "/tmp/games-defer-test/text.games/")))) +(defun test-init-defer-games--declaration-installs-p (init package) + "Return non-nil when INIT (init.el's text) declares PACKAGE in an installing form. +A `use-package' form that carries `:ensure nil' or `:load-path' does not +install (use-package suppresses `use-package-always-ensure' for both), so +the check rejects those rather than accepting any form that names the package." + (and (string-match (format "^(use-package %s\\b\\([^\n]*\\))[ \t]*$" + (regexp-quote package)) + init) + (let ((args (match-string 1 init))) + (not (string-match-p ":ensure nil\\|:load-path" args))))) + +(ert-deftest test-init-defer-games-init-declares-both-packages () + "Normal: init.el declares malyon and 2048-game in forms that install them. +`use-package-always-ensure' is the installer for these two. a8571eff dropped +the declarations along with the eager require, and both packages silently +vanished on the next rebuild while every other test still passed." + (let ((init (with-temp-buffer + (insert-file-contents (expand-file-name "init.el" default-directory)) + (buffer-string)))) + (should (test-init-defer-games--declaration-installs-p init "malyon")) + (should (test-init-defer-games--declaration-installs-p init "2048-game")))) + +(ert-deftest test-init-defer-games-declaration-check-rejects-non-installing-forms () + "Boundary: the declaration check refuses forms use-package would not install." + (should-not (test-init-defer-games--declaration-installs-p + "(use-package malyon :ensure nil :defer t)\n" "malyon")) + (should-not (test-init-defer-games--declaration-installs-p + "(use-package malyon :load-path \"~/x\" :defer t)\n" "malyon")) + (should (test-init-defer-games--declaration-installs-p + "(use-package malyon :defer t :commands (malyon))\n" "malyon"))) + (provide 'test-init-defer-games) ;;; test-init-defer-games.el ends here diff --git a/tests/test-integration-recurring-events.el b/tests/test-integration-recurring-events.el index 8339d167..44ddfb00 100644 --- a/tests/test-integration-recurring-events.el +++ b/tests/test-integration-recurring-events.el @@ -24,13 +24,22 @@ ;;; Setup and Teardown +(defvar test-integration-recurring-events--saved-tz nil + "The TZ in force before setup pinned it, restored by teardown.") + (defun test-integration-recurring-events-setup () - "Setup for recurring events integration tests." - nil) + "Setup for recurring events integration tests. +Pins TZ to America/Chicago: the fixtures are TZID=America/Chicago and the +assertions expect that zone's local rendering (\"Sat 10:30-11:00\"), so on +any other machine zone the pipeline's correct conversion reads as a failure. +`setenv' on TZ also calls `set-time-zone-rule', which is what the time +functions actually consult." + (setq test-integration-recurring-events--saved-tz (getenv "TZ")) + (setenv "TZ" "America/Chicago")) (defun test-integration-recurring-events-teardown () - "Teardown for recurring events integration tests." - nil) + "Teardown for recurring events integration tests: restore the machine TZ." + (setenv "TZ" test-integration-recurring-events--saved-tz)) ;;; Test Data 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-package-resilience.el b/tests/test-package-resilience.el new file mode 100644 index 00000000..d5fdde4a --- /dev/null +++ b/tests/test-package-resilience.el @@ -0,0 +1,504 @@ +;;; test-package-resilience.el --- Tests for surviving failed package installs -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for package-resilience.el, which keeps a failed package download from +;; aborting init. The regression these guard is concrete: early-init.el sets +;; `debug-on-error' during startup so config errors are loud, and that disarms +;; the `condition-case-unless-debug' inside `use-package-ensure-elpa', so one +;; transient download error dropped a fresh install into the debugger with two +;; thirds of the config unloaded. +;; +;; The fakes below stand in for the package archive so no test touches the +;; network or the real elpa directory. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'package-resilience) + +;;; ------------------------------- Fake registry ------------------------------- + +(defvar test-pkg-res--installed nil + "Package symbols the fake registry considers installed.") + +(defvar test-pkg-res--install-log nil + "Packages `package-install' was called with, newest first.") + +(defvar test-pkg-res--failures nil + "Alist of (PACKAGE . N): the next N install attempts for PACKAGE signal.") + +(defvar test-pkg-res--dynamic-state nil + "Captured dynamic state at each `package-install' call, newest first.") + +(defun test-pkg-res--should-fail-p (package) + "Return non-nil when this attempt at PACKAGE should signal, and count it." + (let ((cell (assq package test-pkg-res--failures))) + (when (and cell (> (cdr cell) 0)) + (setcdr cell (1- (cdr cell))) + t))) + +(defun test-pkg-res--install (package) + "Fake `package-install' for PACKAGE: record the call, then fail or install." + (push package test-pkg-res--install-log) + (push (list :debug-on-error debug-on-error + :find-file-hook find-file-hook + :prog-mode-hook prog-mode-hook + :lisp-data-mode-hook lisp-data-mode-hook + :emacs-lisp-mode-hook emacs-lisp-mode-hook) + test-pkg-res--dynamic-state) + (if (test-pkg-res--should-fail-p package) + (signal 'file-error (list "https://elpa.example.invalid/x.tar" "No Data")) + (push package test-pkg-res--installed))) + +(defmacro test-pkg-res--with-registry (available installed failures &rest body) + "Run BODY against a fake package registry. +AVAILABLE lists package symbols the archives carry, INSTALLED those already +installed, and FAILURES is an alist of (PACKAGE . N) attempts that signal." + (declare (indent 3) (debug t)) + `(let ((test-pkg-res--installed (copy-sequence ,installed)) + (test-pkg-res--install-log nil) + (test-pkg-res--failures (copy-tree ,failures)) + (test-pkg-res--dynamic-state nil) + (cj/failed-package-installs nil) + (cj/failed-source-package-installs nil) + (cj/package-install-retry-delay 0) + ;; Both of these accumulate across a whole session by design, so a + ;; test that leaves them set changes what a later test does: an + ;; unbound failure counter tripped the circuit breaker and three + ;; install tests stopped installing anything at all. + (cj/--package-retry-spent 0.0) + (cj/--package-consecutive-failures 0) + (package-archive-contents (mapcar #'list ,available))) + (cl-letf (((symbol-function 'package-installed-p) + (lambda (pkg &rest _) (and (memq pkg test-pkg-res--installed) t))) + ((symbol-function 'package-install) + (lambda (pkg &rest _) (test-pkg-res--install pkg))) + ((symbol-function 'package-refresh-contents) (lambda (&rest _) nil)) + ((symbol-function 'package-read-all-archive-contents) (lambda (&rest _) nil)) + ((symbol-function 'sleep-for) (lambda (&rest _) nil))) + ,@body))) + +;;; --------------------------- Resolving :ensure args -------------------------- + +(ert-deftest test-package-resilience-packages-resolves-t-to-name () + "Normal: an :ensure of t resolves to the use-package form's own name." + (should (equal '(foo) (cj/--package-ensure-packages 'foo '(t))))) + +(ert-deftest test-package-resilience-packages-resolves-explicit-symbol () + "Normal: an explicit :ensure symbol names a different package." + (should (equal '(bar) (cj/--package-ensure-packages 'foo '(bar))))) + +(ert-deftest test-package-resilience-packages-nil-ensure-is-empty () + "Boundary: :ensure nil requests no package at all." + (should (equal '() (cj/--package-ensure-packages 'foo '(nil))))) + +(ert-deftest test-package-resilience-packages-unwraps-pinned-cons () + "Boundary: a pinned (PACKAGE . ARCHIVE) cell resolves to the package symbol." + (should (equal '(bar) (cj/--package-ensure-packages 'foo '((bar . "melpa")))))) + +(ert-deftest test-package-resilience-packages-accepts-string-name () + "Boundary: a use-package form named with a string still resolves to a symbol." + (should (equal '(foo) (cj/--package-ensure-packages "foo" '(t))))) + +(ert-deftest test-package-resilience-packages-handles-several-ensures () + "Boundary: several :ensure keywords resolve to several packages." + (should (equal '(bar baz) (cj/--package-ensure-packages 'foo '(bar baz))))) + +;;; ------------------------------ Installing ---------------------------------- + +(ert-deftest test-package-resilience-installs-missing-package () + "Normal: a missing package is installed and nothing is recorded as failed." + (test-pkg-res--with-registry '(foo) '() '() + (cj/package-ensure 'foo '(t) nil) + (should (equal '(foo) test-pkg-res--install-log)) + (should (memq 'foo test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-skips-installed-package () + "Normal: an already-installed package is never downloaded again." + (test-pkg-res--with-registry '(foo) '(foo) '() + (cj/package-ensure 'foo '(t) nil) + (should-not test-pkg-res--install-log) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-survives-failure-under-debug-on-error () + "Error: a failed install is recorded, not signalled, even with debug-on-error. +This is the regression: `condition-case-unless-debug' inside use-package does +not catch while `debug-on-error' is non-nil, so a transient download error +aborted init in place." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((debug-on-error t)) + (cj/package-ensure 'foo '(t) nil) + (should (memq 'foo cj/failed-package-installs)) + (should-not (memq 'foo test-pkg-res--installed))))) + +(ert-deftest test-package-resilience-retries-transient-failure () + "Error: a download that fails once and then succeeds installs on the retry." + (test-pkg-res--with-registry '(foo) '() '((foo . 1)) + (cj/package-ensure 'foo '(t) nil) + (should (= 2 (length test-pkg-res--install-log))) + (should (memq 'foo test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-stops-after-configured-retries () + "Boundary: a package that always fails is attempted retries-plus-one times." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((cj/package-install-retries 2)) + (cj/package-ensure 'foo '(t) nil) + (should (= 3 (length test-pkg-res--install-log))) + (should (memq 'foo cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-does-not-retry-unknown-package () + "Boundary: a package no archive carries is attempted once, then recorded. +Retrying a name the archives have never heard of only burns refreshes." + (test-pkg-res--with-registry '() '() '((foo . 999)) + (let ((cj/package-install-retries 2)) + (cj/package-ensure 'foo '(t) nil) + (should (= 1 (length test-pkg-res--install-log))) + (should (memq 'foo cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-inhibits-editing-hooks-during-install () + "Error: editing hooks are silenced while a package installs. +Installation generates autoloads by visiting .el files, so a hook belonging to +a package that failed earlier would otherwise break unrelated installs." + (test-pkg-res--with-registry '(foo) '() '() + (let ((find-file-hook '(ignore)) + (prog-mode-hook '(ignore)) + (lisp-data-mode-hook '(ignore)) + (emacs-lisp-mode-hook '(ignore))) + (cj/package-ensure 'foo '(t) nil) + (let ((seen (car test-pkg-res--dynamic-state))) + (should-not (plist-get seen :find-file-hook)) + (should-not (plist-get seen :prog-mode-hook)) + (should-not (plist-get seen :lisp-data-mode-hook)) + (should-not (plist-get seen :emacs-lisp-mode-hook)) + (should-not (plist-get seen :debug-on-error)))))) + +(ert-deftest test-package-resilience-records-each-failure-once () + "Boundary: repeated ensure calls for one package record it a single time." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (cj/package-ensure 'foo '(t) nil) + (cj/package-ensure 'foo '(t) nil) + (should (equal '(foo) cj/failed-package-installs)))) + +;;; ------------------------------ Retry budget --------------------------------- + +(ert-deftest test-package-resilience-budget-caps-retrying () + "Boundary: with the retry budget spent, a failure gets its one attempt only. +An offline machine fails every package, so an uncapped per-package retry would +turn the abort this module removes into a startup that appears to hang." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((cj/package-install-retries 2) + (cj/--package-retry-spent 999.0)) + (cj/package-ensure 'foo '(t) nil) + (should (= 1 (length test-pkg-res--install-log))) + (should (memq 'foo cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-budget-still-records-failures () + "Boundary: a package skipped for budget is still recorded and reportable." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((cj/--package-retry-spent 999.0)) + (cj/package-ensure 'foo '(t) nil) + (should (equal '(foo) (cj/package-still-missing)))))) + +(ert-deftest test-package-resilience-budget-accrues-across-packages () + "Error: retry time spent on one package counts against the next one's budget. +The budget is per session, not per package, which is what bounds a machine +offline for all ~190 of them. The clock is advanced ten seconds per reading so +the accrual is real rather than an artifact of a mocked sleep." + (test-pkg-res--with-registry '(foo bar) '() '((foo . 999) (bar . 999)) + (let ((cj/package-install-retries 2) + (cj/package-install-retry-budget 15.0) + (cj/--package-retry-spent 0.0) + (clock 0.0)) + (cl-letf (((symbol-function 'float-time) + (lambda (&rest _) (setq clock (+ clock 10.0))))) + (cj/package-ensure 'foo '(t) nil) + (cj/package-ensure 'bar '(t) nil)) + ;; foo: one attempt plus two retries, spending 20s. bar: one attempt, + ;; because foo already overspent the shared budget. + (should (= 4 (length test-pkg-res--install-log))) + (should (> cj/--package-retry-spent cj/package-install-retry-budget))))) + +;;; ----------------------------- Circuit breaker ------------------------------- + +(ert-deftest test-package-resilience-stops-attempting-after-failure-run () + "Error: enough failures in a row and later packages are recorded untried. +Offline, nothing populates the archive list, so every single attempt pays a +full `package-refresh-contents' before failing. Across ~190 packages that is +the dominant cost, and no retry ceiling bounds it." + (test-pkg-res--with-registry '(a b c) '() '((a . 999) (b . 999) (c . 999)) + (let ((cj/package-install-retries 0) + (cj/package-install-failure-limit 2)) + (cj/package-ensure 'a '(t) nil) + (cj/package-ensure 'b '(t) nil) + (cj/package-ensure 'c '(t) nil) + ;; a and b were tried; c was not, because the run had already reached 2. + (should (equal '(b a) test-pkg-res--install-log)) + (should (memq 'c cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-failure-run-resets-on-success () + "Boundary: one success clears the run, so an unlucky package is not fatal. +The breaker exists to detect a dead network, not to give up after N scattered +failures across an otherwise healthy install." + (test-pkg-res--with-registry '(a b c) '() '((a . 999) (c . 999)) + (let ((cj/package-install-retries 0) + (cj/package-install-failure-limit 2)) + (cj/package-ensure 'a '(t) nil) ; fails, run = 1 + (cj/package-ensure 'b '(t) nil) ; succeeds, run = 0 + (cj/package-ensure 'c '(t) nil) ; fails, run = 1, still under the limit + (should (equal '(c b a) test-pkg-res--install-log))))) + +(ert-deftest test-package-resilience-installed-package-does-not-clear-run () + "Boundary: a package that was already present tells us nothing about the net. +Counting it as a success would reset the run on every built-in-backed form and +the breaker would never trip on an offline machine." + (test-pkg-res--with-registry '(a b c) '(b) '((a . 999) (c . 999)) + (let ((cj/package-install-retries 0) + (cj/package-install-failure-limit 2)) + (cj/package-ensure 'a '(t) nil) ; fails, run = 1 + (cj/package-ensure 'b '(t) nil) ; already installed, untouched + (cj/package-ensure 'c '(t) nil) ; fails, run = 2 + (should (equal '(c a) test-pkg-res--install-log)) + (should (cj/--package-giving-up-p))))) + +;;; --------------------- Packages installed from source (:vc) ------------------ + +(defun test-pkg-res--vc-orig (fails) + "Return a fake `use-package-vc-install' that signals when FAILS is non-nil." + (lambda (arg &optional _local-path) + (push (car arg) test-pkg-res--install-log) + (if fails + (signal 'error (list "Cloning failed: Permission denied (publickey)")) + (push (car arg) test-pkg-res--installed)))) + +(ert-deftest test-package-resilience-vc-install-succeeds-quietly () + "Normal: a working source install is not recorded as a failure." + (test-pkg-res--with-registry '() '() '() + (cj/--package-vc-install-guard (test-pkg-res--vc-orig nil) '(gloss nil nil)) + (should (memq 'gloss test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-vc-install-survives-failed-clone () + "Error: a failed clone is recorded, not signalled, even with debug-on-error. +`:vc' forms route around `use-package-ensure-function' entirely and +`use-package-vc-install' has no error handling, so without this guard a fresh +machine lacking credentials for the git host aborts init exactly as before." + (test-pkg-res--with-registry '() '() '() + (let ((debug-on-error t)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(gloss nil nil)) + (should (memq 'gloss cj/failed-source-package-installs)) + (should (memq 'gloss (cj/package-still-missing))) + ;; Never the archive list: `package-install' cannot recover a source + ;; package, and for one that also exists on an archive it would install + ;; the archive build instead of the checkout that was asked for. + (should-not (memq 'gloss cj/failed-package-installs)) + (should-not (memq 'gloss test-pkg-res--installed))))) + +(ert-deftest test-package-resilience-vc-failure-counts-toward-breaker () + "Error: a failed clone counts toward the consecutive-failure run. +No credentials means every source package fails, the same shape as no network." + (test-pkg-res--with-registry '() '() '() + (let ((cj/package-install-failure-limit 2)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(gloss nil nil)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(chime nil nil)) + (should (cj/--package-giving-up-p))))) + +(ert-deftest test-package-resilience-vc-skipped-once-breaker-tripped () + "Boundary: with the breaker tripped a source install is recorded untried." + (test-pkg-res--with-registry '() '() '() + (let ((cj/--package-consecutive-failures 99)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(gloss nil nil)) + (should-not test-pkg-res--install-log) + (should (memq 'gloss cj/failed-source-package-installs))))) + +(ert-deftest test-package-resilience-vc-installed-package-passes-through () + "Boundary: an already-installed source package neither counts nor records. +It says nothing about whether the git host is reachable, so treating it as a +success would reset the run and stop the breaker ever tripping." + (test-pkg-res--with-registry '() '(gloss) '() + (let ((cj/--package-consecutive-failures 3)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig nil) '(gloss nil nil)) + (should (= 3 cj/--package-consecutive-failures)) + (should-not cj/failed-package-installs)))) + +(ert-deftest test-package-resilience-vc-success-clears-failure-run () + "Boundary: a clone that works clears the run, like any other install." + (test-pkg-res--with-registry '() '() '() + (let ((cj/--package-consecutive-failures 3)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig nil) '(gloss nil nil)) + (should (= 0 cj/--package-consecutive-failures))))) + +;;; --------------------------------- Retrying ---------------------------------- + +(ert-deftest test-package-resilience-retry-clears-recovered-package () + "Normal: retrying installs a package that is now reachable and clears it." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs '(foo)) + (cj/retry-failed-package-installs) + (should (memq 'foo test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-retry-converges-on-cascade () + "Boundary: a package installable only on a later pass still converges. +A failed package leaves hooks that break other installs, so recovery has to +keep passing over the set until a pass installs nothing new." + (test-pkg-res--with-registry '(foo bar) '() '((bar . 1)) + (setq cj/failed-package-installs '(foo bar)) + (cj/retry-failed-package-installs) + (should (memq 'foo test-pkg-res--installed)) + (should (memq 'bar test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-retry-leaves-source-packages-alone () + "Boundary: retrying never runs `package-install' on a source package. +It cannot recover one, and for a source package that also exists on an archive +it would install the archive build instead of the checkout that was declared, +leaving `package-installed-p' true and the source install permanently skipped." + (test-pkg-res--with-registry '(gloss) '() '() + (setq cj/failed-source-package-installs '(gloss)) + (cj/retry-failed-package-installs) + (should-not test-pkg-res--install-log) + (should (equal '(gloss) (cj/package-still-missing))))) + +(ert-deftest test-package-resilience-retry-works-with-empty-archive-list () + "Error: recovery still attempts installs when no archive list is loaded yet. +This is the case the command exists for: a laptop that booted before its wifi +came up has an empty `package-archive-contents', and screening recorded +packages against it would make the command a silent no-op right when the user +finally has a network. `package-install' populates the archives itself." + (test-pkg-res--with-registry '() '() '() + (setq cj/failed-package-installs '(foo bar)) + (should-not package-archive-contents) + (cj/retry-failed-package-installs) + (should (equal '(bar foo) test-pkg-res--install-log)) + (should-not (cj/package-still-missing)))) + +(ert-deftest test-package-resilience-retry-terminates-when-impossible () + "Error: a package that can never install terminates the loop and stays listed." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (setq cj/failed-package-installs '(foo)) + (cj/retry-failed-package-installs) + (should (equal '(foo) cj/failed-package-installs)))) + +(ert-deftest test-package-resilience-retry-with-nothing-failed-is-quiet () + "Boundary: retrying an empty failure set installs nothing." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs nil) + (cj/retry-failed-package-installs) + (should-not test-pkg-res--install-log))) + +;;; -------------------------------- Reporting ---------------------------------- + +(ert-deftest test-package-resilience-report-is-silent-when-clean () + "Normal: a run with no failed installs raises no warning." + (test-pkg-res--with-registry '() '() '() + (let ((warned nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (&rest _) (setq warned t)))) + (cj/report-failed-package-installs) + (should-not warned))))) + +(ert-deftest test-package-resilience-still-missing-does-not-mutate-records () + "Error: reading the missing set leaves both record lists intact. +`append' does not copy its last argument and `delete-dups' splices, so the +obvious spelling edits `cj/failed-source-package-installs' in place. Reading a +value must not destroy it, least of all from the startup report." + (test-pkg-res--with-registry '() '() '() + (setq cj/failed-package-installs '(foo shared)) + (setq cj/failed-source-package-installs '(gloss shared chime)) + (cj/package-still-missing) + (should (equal '(foo shared) cj/failed-package-installs)) + (should (equal '(gloss shared chime) cj/failed-source-package-installs)))) + +(ert-deftest test-package-resilience-report-omits-package-installed-since () + "Boundary: a package that arrived later as a dependency is not reported. +It failed on its own use-package form, so it is on the recorded list, but it is +present now and there is nothing for the user to do about it." + (test-pkg-res--with-registry '(foo bar) '(foo) '() + (setq cj/failed-package-installs '(foo bar)) + (should (equal '(bar) (cj/package-still-missing))) + (let ((message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should (string-match-p "bar" message-text)) + (should-not (string-match-p "foo" message-text)))))) + +(ert-deftest test-package-resilience-report-silent-when-all-arrived-since () + "Boundary: recorded failures that are all installed now raise no warning." + (test-pkg-res--with-registry '(foo) '(foo) '() + (setq cj/failed-package-installs '(foo)) + (let ((warned nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (&rest _) (setq warned t)))) + (cj/report-failed-package-installs) + (should-not warned))))) + +(ert-deftest test-package-resilience-report-says-when-it-stopped-early () + "Error: a tripped breaker is said out loud, so untried is not read as failed. +Most of a long list would never have been attempted, and reporting those as +install failures would send the user hunting for ~185 individual problems." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs '(foo)) + (let ((cj/--package-consecutive-failures 99) + (message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should (string-match-p "never" message-text)) + ;; Names both causes: a run of failures is a dead network or missing + ;; credentials, and the message should not pick one. + (should (string-match-p "network" message-text)) + (should (string-match-p "credentials" message-text)))))) + +(ert-deftest test-package-resilience-report-omits-early-stop-when-not-tripped () + "Boundary: an ordinary failure is not dressed up as a machine being offline." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs '(foo)) + (let ((cj/--package-consecutive-failures 0) + (message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should-not (string-match-p "never" message-text)))))) + +(ert-deftest test-package-resilience-report-warns-and-names-failures () + "Error: failed installs raise one warning that names every package." + (test-pkg-res--with-registry '(foo bar) '() '() + (setq cj/failed-package-installs '(foo bar)) + (let ((message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should message-text) + (should (string-match-p "foo" message-text)) + (should (string-match-p "bar" message-text)))))) + +;;; ---------------------------------- Wiring ----------------------------------- + +;; The guard tests above call the functions directly, which says nothing about +;; whether they are actually reachable from a real startup. If use-package +;; renamed either seam, every test above would still pass while the whole +;; module sat dead -- this repo's recurring failure, a gate that was green +;; because it never ran. + +(ert-deftest test-package-resilience-is-wired-to-use-package () + "Normal: loading the module actually takes over both use-package seams. +`advice-member-p' answers yes for advice attached to a symbol that was never +defined, so it alone would still pass if upstream renamed the function and left +the advice on a dead symbol. That rename is the whole scenario this test +exists for, hence the `fboundp'." + (should (eq use-package-ensure-function #'cj/package-ensure)) + (should (fboundp 'use-package-vc-install)) + (should (advice-member-p #'cj/--package-vc-install-guard + 'use-package-vc-install))) + +(ert-deftest test-package-resilience-reports-at-startup () + "Normal: the end-of-startup report is on `emacs-startup-hook'." + (should (memq #'cj/report-failed-package-installs + (default-value 'emacs-startup-hook)))) + +(provide 'test-package-resilience) +;;; test-package-resilience.el ends here diff --git a/tests/test-prog-general-yas-activation.el b/tests/test-prog-general-yas-activation.el index d6ea42cd..d9ae76e3 100644 --- a/tests/test-prog-general-yas-activation.el +++ b/tests/test-prog-general-yas-activation.el @@ -122,7 +122,11 @@ produces the marker block." "Boundary: <cj + expand in python-ts-mode (a tree-sitter prog-mode-derived mode) produces the marker block. Verifies the snippet reaches modern tree-sitter modes through fundamental-mode inheritance." - (skip-unless (fboundp 'python-ts-mode)) + ;; `python-ts-mode' prompts to install a missing grammar, which a batch run + ;; cannot answer, so skip on the grammar rather than on the mode's existence. + (skip-unless (and (fboundp 'python-ts-mode) + (require 'treesit nil t) + (treesit-ready-p 'python t))) (should (string= (test-prog-general--expand-cj-in-mode #'python-ts-mode) test-prog-general--cj-expected))) diff --git a/tests/test-setup-telega.bats b/tests/test-setup-telega.bats index 3282b9e1..518ecc7b 100644 --- a/tests/test-setup-telega.bats +++ b/tests/test-setup-telega.bats @@ -57,11 +57,11 @@ setup() { # --------------------------- pull_or_announce_image ----------------------- -@test "pull_or_announce_image: announces the in-Emacs build when no image is set" { +@test "pull_or_announce_image: points at make telega-image when no image is set" { TELEGA_DOCKER_IMAGE="" run pull_or_announce_image [ "$status" -eq 0 ] - [[ "$output" == *"M-x telega-server-build"* ]] + [[ "$output" == *"make telega-image"* ]] } @test "pull_or_announce_image: pulls when TELEGA_DOCKER_IMAGE is set" { diff --git a/tests/test-system-commands-resolve-and-run.el b/tests/test-system-commands-resolve-and-run.el index 7e5146b1..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 () diff --git a/tests/test-system-defaults--warning-display-dead-buffer.el b/tests/test-system-defaults--warning-display-dead-buffer.el new file mode 100644 index 00000000..48c7797e --- /dev/null +++ b/tests/test-system-defaults--warning-display-dead-buffer.el @@ -0,0 +1,103 @@ +;;; test-system-defaults--warning-display-dead-buffer.el --- Dead-buffer guard on deferred warnings -*- lexical-binding: t; -*- + +;;; Commentary: +;; Emacs 31.1's warnings.el defers daemon-startup warnings into a one-shot +;; `after-make-frame-functions' closure that calls `warning--display-buffer' +;; on the first client frame with the *Warnings* buffer object it captured at +;; warning time. If anything killed that buffer in between, `display-buffer' +;; signals inside `make-frame', server.el swallows the error as +;; "-window-system-unsupported", and emacsclient silently retries on $DISPLAY: +;; the session's first frame lands on XWayland. +;; +;; The root fix keeps *Warnings* alive (undead-buffers.el). This is the +;; defense in depth: `cj/warning--display-buffer-if-live' wraps +;; `warning--display-buffer' so a dead buffer is skipped rather than passed +;; on. Load happens once in the shared sandbox (testutil-system-defaults.el); +;; `warning--display-buffer' only exists from Emacs 31, so the end-to-end case +;; skips on older builds while the pure-function cases always run. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-system-defaults) + +(test-system-defaults--with-load-environment + (test-system-defaults--load)) + +(defun test-system-defaults--recording-orig () + "Return (ORIG . CALLS) where ORIG records every argument into CALLS." + (let ((calls (list nil))) + (cons (lambda (buffer) + (push buffer (car calls)) + 'displayed) + calls))) + +;;; Normal Cases + +(ert-deftest test-system-defaults-warning-guard-passes-live-buffer-through () + "Normal: a live buffer reaches the original and its value is returned." + (let* ((rec (test-system-defaults--recording-orig)) + (buf (generate-new-buffer " *warning-guard-live*"))) + (unwind-protect + (progn + (should (eq 'displayed + (cj/warning--display-buffer-if-live (car rec) buf))) + (should (equal (list buf) (car (cdr rec))))) + (kill-buffer buf)))) + +(ert-deftest test-system-defaults-warning-guard-is-installed () + "Normal: loading system-defaults installs the guard on the deferred display. +From Emacs 31 the advised symbol must actually be defined: pending advice on +an undefined symbol would still count as installed, so a rename upstream +would otherwise silently disable the backstop." + (should (advice-member-p #'cj/warning--display-buffer-if-live + 'warning--display-buffer)) + (when (>= emacs-major-version 31) + (should (fboundp 'warning--display-buffer)))) + +(ert-deftest test-system-defaults-warning-guard-resolves-live-buffer-name () + "Normal: a live buffer's name is resolved and passed through as the buffer." + (let* ((rec (test-system-defaults--recording-orig)) + (buf (generate-new-buffer " *warning-guard-named*"))) + (unwind-protect + (progn + (should (eq 'displayed + (cj/warning--display-buffer-if-live + (car rec) (buffer-name buf)))) + (should (equal (list buf) (car (cdr rec))))) + (kill-buffer buf)))) + +;;; Boundary Cases + +(ert-deftest test-system-defaults-warning-guard-skips-killed-buffer () + "Boundary: a killed buffer never reaches the original; result is nil." + (let* ((rec (test-system-defaults--recording-orig)) + (buf (generate-new-buffer " *warning-guard-dead*"))) + (kill-buffer buf) + (should-not (cj/warning--display-buffer-if-live (car rec) buf)) + (should-not (car (cdr rec))))) + +(ert-deftest test-system-defaults-warning-guard-end-to-end-dead-buffer-does-not-signal () + "Boundary: the real deferred display survives a dead buffer. +Mirrors the live failure: a string condition in `display-buffer-alist' is +what `buffer-match-p' tripped over when the buffer name came back nil." + (skip-unless (fboundp 'warning--display-buffer)) + (let ((buf (generate-new-buffer "*Warnings*")) + (display-buffer-alist '(("^ \\*test-guard\\*" display-buffer-no-window)))) + (kill-buffer buf) + (should-not (warning--display-buffer buf)))) + +;;; Error Cases + +(ert-deftest test-system-defaults-warning-guard-rejects-non-buffer () + "Error: nil, or a name that resolves to no buffer, is skipped without a signal." + (let ((rec (test-system-defaults--recording-orig)) + (missing " *warning-guard-no-such-buffer*")) + (when (get-buffer missing) (kill-buffer missing)) + (should-not (cj/warning--display-buffer-if-live (car rec) nil)) + (should-not (cj/warning--display-buffer-if-live (car rec) missing)) + (should-not (car (cdr rec))))) + +(provide 'test-system-defaults--warning-display-dead-buffer) +;;; test-system-defaults--warning-display-dead-buffer.el ends here diff --git a/tests/test-system-defaults-functions.el b/tests/test-system-defaults-functions.el index 4b647166..09bf9f2a 100644 --- a/tests/test-system-defaults-functions.el +++ b/tests/test-system-defaults-functions.el @@ -55,6 +55,12 @@ ;; so it doesn't leak into a shared batch session. `make test-name' loads ;; every test file into one Emacs; a leaked cwd there breaks the relative ;; loads of every file that follows. +;; Declared special before the `let' below binds it: this file is lexical, +;; so without the defvar the binding is a lexical local, and use-package's +;; own `defcustom' then fails with "Defining as dynamic an already lexical +;; var" (fatal at load since 31.1 moved the defcustom to autoload time). +(defvar use-package-always-ensure) + (let ((default-directory default-directory) (use-package-always-ensure nil)) (cl-letf (((symbol-function 'server-running-p) (lambda (&rest _) t)) 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 index 894dbfdd..8f5b62bd 100644 --- a/tests/test-telega-config--docker-pin.el +++ b/tests/test-telega-config--docker-pin.el @@ -5,9 +5,15 @@ ;; ;; 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 +;; ".0". This config has min "1.8.66" 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. +;; +;; Since 2026-08-25 the pin names an image built locally from +;; docker/telega-server/Dockerfile (upstream's image is missing a shared +;; library, zevlg/telega.el#596). Three files have to agree on that image: +;; the defcustom default, the Makefile's build tag, and the Dockerfile's +;; digest-pinned base. The tests below hold them together. ;;; Code: @@ -17,6 +23,18 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'telega-config) +(defun test-telega-config--file-string (relative) + "Return the contents of RELATIVE under `user-emacs-directory'." + (with-temp-buffer + (insert-file-contents (expand-file-name relative user-emacs-directory)) + (buffer-string))) + +(defun test-telega-config--pin-default () + "Return the defcustom's shipped default, not the live value. +Customizing the pin (including to nil) is not a test failure; only +changing the shipped default is." + (eval (car (get 'cj/telega-docker-image 'standard-value)) t)) + ;; -- cj/--telega-docker-pinned-image ----------------------------------------- (ert-deftest test-telega-config-pin-returns-configured-reference () @@ -77,17 +95,118 @@ name, so this stays a reversible setting." "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))) +;; -- the shipped default and the files it depends on ------------------------- + +(ert-deftest test-telega-config-pin-default-matches-makefile-build-tag () + "Normal: the default pin is exactly the tag `make telega-image' builds. +The image is built locally, so the pin is a tag rather than a registry +digest. The Makefile owns the tag; the defcustom must name the same one +or a fresh machine builds an image telega never looks for." + (let ((makefile (test-telega-config--file-string "Makefile"))) + (should (string-match "^TELEGA_IMAGE[ \t]*[?:]?=[ \t]*\\([^ \t\n]+\\)" makefile)) + (should (equal (test-telega-config--pin-default) + (match-string 1 makefile))))) + +(ert-deftest test-telega-config-pin-default-is-a-local-tag-not-a-digest () + "Boundary: the default is a plain tag, with no registry digest suffix. +A locally built image has no RepoDigest, so a digest reference here could +never resolve." + (let ((default (test-telega-config--pin-default))) (should (stringp default)) - (should (string-match-p "@sha256:[0-9a-f]\\{64\\}\\'" default)))) + (should (string-match-p "\\`[a-z0-9./-]+:[A-Za-z0-9._-]+\\'" default)) + (should-not (string-match-p "@sha256:" default)))) + +(ert-deftest test-telega-config-dockerfile-pins-base-image-by-digest () + "Normal: the Dockerfile's base is an immutable upstream digest. +This is where the digest guarantee the old pin gave now lives. A tag in +the FROM line would let upstream swap the base under a rebuild." + (let ((dockerfile (test-telega-config--file-string "docker/telega-server/Dockerfile"))) + (should (string-match-p + "^FROM zevlg/telega-server@sha256:[0-9a-f]\\{64\\}[ \t]*$" + dockerfile)))) + +(ert-deftest test-telega-config-dockerfile-adds-the-missing-library () + "Normal: the Dockerfile installs libglycin, the whole reason it exists. +Upstream's image fails to start without it (zevlg/telega.el#596)." + (let ((dockerfile (test-telega-config--file-string "docker/telega-server/Dockerfile"))) + (should (string-match-p "^RUN apk add .*libglycin" dockerfile)))) + +;; -- cj/--telega-docker-image-present-p (the docker boundary) ---------------- +;; Exercised against a fake `docker' executable on a private exec-path rather +;; than by mocking `call-process' (a subr; see the native-comp mocking gotcha). + +(defun test-telega-config--with-fake-docker (exit-code thunk) + "Call THUNK with a fake `docker' on `exec-path' that exits EXIT-CODE." + (let* ((dir (make-temp-file "fake-docker-" t)) + (script (expand-file-name "docker" dir))) + (unwind-protect + (progn + (with-temp-file script + (insert (format "#!/bin/sh\nexit %d\n" exit-code))) + (set-file-modes script #o700) + (let ((exec-path (list dir))) + (funcall thunk))) + (delete-directory dir t)))) + +(ert-deftest test-telega-config-image-present-p-true-when-inspect-succeeds () + "Normal: `docker image inspect' exiting 0 means the image is present." + (test-telega-config--with-fake-docker 0 + (lambda () (should (cj/--telega-docker-image-present-p "cj/telega-server:x"))))) + +(ert-deftest test-telega-config-image-present-p-nil-when-inspect-fails () + "Boundary: a non-zero exit (no such image) reads as not present." + (test-telega-config--with-fake-docker 1 + (lambda () (should-not (cj/--telega-docker-image-present-p "cj/telega-server:x"))))) + +(ert-deftest test-telega-config-image-present-p-nil-without-docker () + "Error: with no docker on `exec-path', the helper returns nil instead of +signalling, so the launcher can still route the user to the make target." + (let ((exec-path nil)) + (should-not (cj/--telega-docker-image-present-p "cj/telega-server:x")))) + +;; -- cj/telega refuses to launch against a missing local image --------------- + +(ert-deftest test-telega-config-missing-image-message-names-image-and-target () + "Normal: the message names the missing image and the make target that builds it." + (let ((msg (cj/--telega-missing-image-message "cj/telega-server:x"))) + (should (string-match-p "cj/telega-server:x" msg)) + (should (string-match-p "make telega-image" msg)))) + +(ert-deftest test-telega-config-launcher-errors-when-pinned-image-is-absent () + "Error: with a pin set and no such image, `cj/telega' stops with the make hint. +Without this, docker fails to pull a local-only tag and the error names a +registry the image was never meant to come from." + (let ((cj/telega-docker-image "cj/telega-server:x") + (launched nil)) + (cl-letf (((symbol-function 'locate-library) (lambda (&rest _) "telega.el")) + ((symbol-function 'cj/--telega-docker-image-present-p) (lambda (_) nil)) + ((symbol-function 'telega) (lambda (&rest _) (setq launched t)))) + (let ((err (should-error (cj/telega) :type 'user-error))) + (should (string-match-p "make telega-image" (cadr err)))) + (should-not launched)))) + +(ert-deftest test-telega-config-launcher-runs-when-pinned-image-is-present () + "Normal: with the pinned image present, `cj/telega' launches telega." + (let ((cj/telega-docker-image "cj/telega-server:x") + (launched nil)) + (cl-letf (((symbol-function 'locate-library) (lambda (&rest _) "telega.el")) + ((symbol-function 'cj/--telega-docker-image-present-p) (lambda (_) t)) + ((symbol-function 'telega) (lambda (&rest _) (setq launched t)))) + (cj/telega) + (should launched)))) + +(ert-deftest test-telega-config-launcher-skips-image-check-without-a-pin () + "Boundary: with no pin, telega infers and pulls its own image; no check runs." + (let ((cj/telega-docker-image nil) + (checked nil) + (launched nil)) + (cl-letf (((symbol-function 'locate-library) (lambda (&rest _) "telega.el")) + ((symbol-function 'cj/--telega-docker-image-present-p) + (lambda (_) (setq checked t) nil)) + ((symbol-function 'telega) (lambda (&rest _) (setq launched t)))) + (cj/telega) + (should-not checked) + (should launched)))) (provide 'test-telega-config--docker-pin) ;;; test-telega-config--docker-pin.el ends here diff --git a/tests/test-telega-config.el b/tests/test-telega-config.el index d8aaeb4d..54a601c9 100644 --- a/tests/test-telega-config.el +++ b/tests/test-telega-config.el @@ -45,6 +45,10 @@ stub's cryptic load-file failure." (let (called) (cl-letf (((symbol-function 'featurep) (lambda (sym &optional _sub) (eq sym 'telega))) + ;; The pinned image is a local build; treat it as present so + ;; this test stays about delegation, not the image check. + ((symbol-function 'cj/--telega-docker-image-present-p) + (lambda (_) t)) ((symbol-function 'telega) (lambda (&rest _) (setq called t)))) (cj/telega)) diff --git a/tests/test-term-tmux-detach.el b/tests/test-term-tmux-detach.el new file mode 100644 index 00000000..9bd94776 --- /dev/null +++ b/tests/test-term-tmux-detach.el @@ -0,0 +1,62 @@ +;;; test-term-tmux-detach.el --- Tests for cj/term-tmux-detach -*- lexical-binding: t; -*- + +;;; Commentary: +;; A keyboard C-b inside the Claude Code pane does not reach tmux as a prefix +;; (it lands as stray text), so detaching needs the same pty string path +;; `cj/term-copy-mode-dwim' uses for C-b [. These tests pin that path and +;; the no-tmux fallback. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'package) + +;; Same shape as test-term-tmux-history.el: `make test' runs with no +;; package-initialize, so eat has to be made loadable here before eat-config. +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(setq load-prefer-newer t) +(require 'eat) +(require 'eat-config) + +(ert-deftest test-eat-config-tmux-detach-sends-prefix-and-d-when-attached () + "Normal: with tmux attached, the command writes C-b d into the pty, nothing else." + (let ((sent nil)) + (cl-letf (((symbol-function 'cj/term--in-tmux-p) (lambda () t)) + ((symbol-function 'cj/--term-send-string) (lambda (s) (push s sent)))) + (cj/term-tmux-detach) + (should (equal sent '("\C-bd")))))) + +(ert-deftest test-eat-config-tmux-detach-does-nothing-without-tmux () + "Boundary: with no tmux client, nothing is written and the user is told why. +Writing C-b d into a plain shell would type a control character into it." + (let ((sent nil) + (told nil)) + (cl-letf (((symbol-function 'cj/term--in-tmux-p) (lambda () nil)) + ((symbol-function 'cj/--term-send-string) (lambda (s) (push s sent))) + ((symbol-function 'message) (lambda (fmt &rest args) + (setq told (apply #'format fmt args))))) + (cj/term-tmux-detach) + (should-not sent) + (should (string-match-p "tmux" told))))) + +(ert-deftest test-eat-config-tmux-detach-survives-dead-process () + "Error: with tmux reported attached but no live pty, the command returns +without signalling. `cj/--term-send-string' already guards on +`process-live-p'; this pins that the detach path relies on it rather than +calling `process-send-string' directly." + (with-temp-buffer + (cl-letf (((symbol-function 'cj/term--in-tmux-p) (lambda () t))) + (should-not (condition-case err + (progn (cj/term-tmux-detach) nil) + (error err)))))) + +(ert-deftest test-eat-config-tmux-detach-bound-on-term-map () + "Normal: the command sits on the terminal map next to copy-mode (\"c\")." + (should (eq (keymap-lookup cj/term-map "d") #'cj/term-tmux-detach))) + +(provide 'test-term-tmux-detach) +;;; test-term-tmux-detach.el ends here diff --git a/tests/test-undead-buffers--native-comp-log-undead.el b/tests/test-undead-buffers--native-comp-log-undead.el new file mode 100644 index 00000000..dee9a134 --- /dev/null +++ b/tests/test-undead-buffers--native-comp-log-undead.el @@ -0,0 +1,92 @@ +;;; test-undead-buffers--native-comp-log-undead.el --- the native-comp log survives the sweep -*- lexical-binding: t; -*- + +;;; Commentary: +;; Async native compilation parks every worker process on one buffer, +;; `comp-async-buffer-name' (*Async-native-compile-log*), and the worker's +;; sentinel reads that buffer back before it starts the next job. Killing +;; the buffer sends SIGHUP to every worker under it (they are :noquery, so +;; nothing asks), each sentinel then dies in `with-current-buffer' on the +;; dead buffer, and `comp--run-async-workers' is never called again: the +;; queue is stranded for the life of the daemon and nothing is ever cached. +;; +;; `cj/dashboard-only' on `emacs-startup-hook' runs +;; `cj/kill-all-other-buffers-and-windows', which is exactly such a sweep, +;; and in a real daemon `dashboard-insert-startupify-lists' has already +;; created *dashboard* on `after-init-hook', so the sweep branch is the one +;; that runs. These tests pin the log buffer to the undead list so the +;; sweep buries it and the workers live. The fixture puts a live :noquery +;; process on the buffer, because that is the state the bug needs; a plain +;; buffer would survive a kill-and-recreate just the same. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'undead-buffers) + +(defconst test-undead--comp-log "*Async-native-compile-log*") + +(defun test-undead--make-sleeper (buffer) + "Start a quiet, long-lived process attached to BUFFER and return it." + (make-process :name "test-undead-sleeper" :buffer buffer + :command '("sleep" "30") :noquery t)) + +(defun test-undead--settle () + "Let any signal the sweep sent land before liveness is observed." + (let ((deadline (+ (float-time) 0.3))) + (while (< (float-time) deadline) + (accept-process-output nil 0.05)))) + +;;; Normal Cases + +(ert-deftest test-undead-buffers-native-comp-log-is-undead-by-default () + "Normal: the module's default list makes the async-compile log bury-only." + (should (member test-undead--comp-log cj/undead-buffer-list)) + (should (cj/--buffer-undead-p test-undead--comp-log))) + +(ert-deftest test-undead-buffers-native-comp-log-name-matches-comp-run () + "Normal: the pinned name is the one comp-run actually uses. +A rename upstream would silently reopen the bug, so pin it to the variable." + (skip-unless (require 'comp-run nil t)) + (should (equal comp-async-buffer-name test-undead--comp-log))) + +(ert-deftest test-undead-buffers-native-comp-log-workers-survive-sweep () + "Normal: a worker parked on the log buffer is still running after the sweep. +The positive control is an ordinary process buffer, which the sweep kills +out from under its process -- that is what happened to the workers without +the undead entry. The control's process is not asserted dead: killing the +buffer sends SIGHUP, and a launching shell that ignores SIGHUP (nohup) hands +that disposition down, so its death is not deterministic across harnesses." + (skip-unless (executable-find "sleep")) + (delete-other-windows) + (let* ((main (current-buffer)) + (existing (get-buffer test-undead--comp-log)) + (log (or existing (get-buffer-create test-undead--comp-log))) + (victim (generate-new-buffer "*test-sweep-victim*")) + (worker (test-undead--make-sleeper log)) + (control (test-undead--make-sleeper victim))) + (unwind-protect + (progn + (cj/kill-all-other-buffers-and-windows) + (test-undead--settle) + (should (buffer-live-p main)) + (should (buffer-live-p log)) + (should (process-live-p worker)) + (should-not (buffer-live-p victim))) + (when (process-live-p worker) (delete-process worker)) + (when (process-live-p control) (delete-process control)) + (when (buffer-live-p victim) (kill-buffer victim)) + ;; Only remove what this test created. `kill-buffer' the function is + ;; not the remapped command, so the undead list doesn't apply. + (when (and (not existing) (buffer-live-p log)) (kill-buffer log)) + (delete-other-windows)))) + +;;; Boundary Cases + +(ert-deftest test-undead-buffers-native-comp-log-match-is-exact () + "Boundary: only the exact name is undead; a uniquified copy is not." + (should-not (cj/--buffer-undead-p "*Async-native-compile-log*<2>")) + (should-not (cj/--buffer-undead-p " *Async-native-compile-log*"))) + +(provide 'test-undead-buffers--native-comp-log-undead) +;;; test-undead-buffers--native-comp-log-undead.el ends here diff --git a/tests/test-undead-buffers--warnings-undead.el b/tests/test-undead-buffers--warnings-undead.el new file mode 100644 index 00000000..858dbf76 --- /dev/null +++ b/tests/test-undead-buffers--warnings-undead.el @@ -0,0 +1,63 @@ +;;; test-undead-buffers--warnings-undead.el --- *Warnings* survives the buffer sweep -*- lexical-binding: t; -*- + +;;; Commentary: +;; Emacs 31.1's warnings.el defers daemon-startup warnings into a one-shot +;; `after-make-frame-functions' closure that holds the *Warnings* buffer +;; object and displays it on the first client frame. Killing that buffer +;; during startup leaves the closure holding a dead buffer, `display-buffer' +;; then signals inside `make-frame', server.el reports the window system as +;; unsupported, and emacsclient silently retries on $DISPLAY -- the first +;; frame of the session lands on XWayland instead of Wayland. +;; +;; `cj/dashboard-only' on `emacs-startup-hook' runs +;; `cj/kill-all-other-buffers-and-windows', which is exactly such a sweep. +;; These tests pin *Warnings* to the undead list so the sweep buries it +;; instead of killing it. Error-path coverage of the predicate itself (a nil +;; or non-string name) lives in test-undead-buffers--buffer-undead-p.el. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'undead-buffers) + +;;; Normal Cases + +(ert-deftest test-undead-buffers-warnings-is-undead-by-default () + "Normal: the module's default list makes *Warnings* bury-only." + (should (member "*Warnings*" cj/undead-buffer-list)) + (should (cj/--buffer-undead-p "*Warnings*"))) + +(ert-deftest test-undead-buffers-warnings-survives-kill-all-other-buffers () + "Normal: the startup sweep buries *Warnings* rather than killing it. +This is the sweep `cj/dashboard-only' runs from `emacs-startup-hook'." + (delete-other-windows) + (unwind-protect + (let* ((main (current-buffer)) + (existing (get-buffer "*Warnings*")) + (warnings (or existing (get-buffer-create "*Warnings*"))) + (victim (generate-new-buffer "*test-sweep-victim*"))) + (unwind-protect + (progn + (cj/kill-all-other-buffers-and-windows) + (should (buffer-live-p main)) + (should (buffer-live-p warnings)) + (should-not (buffer-live-p victim))) + (when (buffer-live-p victim) (kill-buffer victim)) + ;; Only remove what this test created. `kill-buffer' the function + ;; is not the remapped command, so the undead list doesn't apply. + (when (and (not existing) (buffer-live-p warnings)) + (kill-buffer warnings)))) + (delete-other-windows))) + +;;; Boundary Cases + +(ert-deftest test-undead-buffers-warnings-match-is-exact () + "Boundary: only the exact name is undead; a uniquified *Warnings*<2> is not. +The list matches exact names, so a second warnings buffer made by +`generate-new-buffer' is an ordinary buffer to the sweep." + (should-not (cj/--buffer-undead-p "*Warnings*<2>")) + (should-not (cj/--buffer-undead-p " *Warnings*"))) + +(provide 'test-undead-buffers--warnings-undead) +;;; test-undead-buffers--warnings-undead.el ends here 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 |