diff options
103 files changed, 7961 insertions, 2320 deletions
@@ -5,6 +5,7 @@ /.coverage/ flycheck_* projectile-bookmarks.eld +projectile-frecency.eld /fontaine-latest-state.eld /recentf /backups/ @@ -55,6 +56,7 @@ auto-save-list/ /browser-choice.el /calendar-sync.local.el /signal-config.local.el +/google-keep.local.el /client_secret_491339091045-sjje1r54s22vn2ugh45khndjafp89vto.apps.googleusercontent.com.json # reveal.js local clone (managed by scripts/setup-reveal.sh) @@ -16,6 +16,8 @@ # make compile - Byte-compile all modules # make compile-file FILE= - Byte-compile one file with the project load path # make lint - Run all linters (checkdoc, package-lint, elisp-lint) +# make bootstrap - Install every package headlessly (fresh machine) +# make telega-image - Build the telega-server container image # make profile - Profile Emacs startup performance # make clean - Remove test artifacts and compiled files # make clean-compiled - Remove .elc/.eln files only @@ -54,7 +56,7 @@ EMACS_TEST = $(EMACS_BATCH) -L $(TEST_DIR) -L $(MODULE_DIR) .PHONY: help targets test test-all test-unit test-integration test-file test-name \ test-bash theme-studio-test theme-studio-check theme-studio-coverage theme-studio-gen theme-studio-open theme-studio-theme theme-studio-theme-load theme-studio-theme-reload deploy-wip \ benchmark coverage coverage-summary coverage-clean \ - validate-parens validate-modules compile compile-file lint profile \ + validate-parens validate-modules compile compile-file lint bootstrap telega-image profile \ task-sorted \ clean clean-compiled clean-tests reset @@ -100,6 +102,8 @@ help: @echo " make lint - Run all linters (checkdoc, package-lint, elisp-lint)" @echo "" @echo " Utilities:" + @echo " make bootstrap - Install every package headlessly (fresh machine)" + @echo " make telega-image - Build the telega-server container image" @echo " make profile - Profile Emacs startup performance" @echo " make clean - Remove test artifacts and compiled files" @echo " make clean-compiled - Remove .elc/.eln files only" @@ -452,6 +456,19 @@ lint: # Utility Targets # ============================================================================ +bootstrap: + @bash scripts/bootstrap-packages.sh + +# telega-server container image. Built locally from a digest-pinned upstream +# base plus the library upstream forgot (see docker/telega-server/Dockerfile). +# The tag here is the source of truth: `cj/telega-docker-image' in +# modules/telega-config.el must name the same one, and a test holds them equal. +TELEGA_IMAGE = cj/telega-server:1.8.66-glycin + +telega-image: + @docker build -t $(TELEGA_IMAGE) docker/telega-server + @echo "built $(TELEGA_IMAGE)" + profile: @echo "Profiling Emacs startup..." @if [ -f "$(EMACS_HOME)/early-init.el" ]; then \ diff --git a/custom/elpa-mirror.el b/custom/elpa-mirror.el index 777293e2..a17d0c5f 100644 --- a/custom/elpa-mirror.el +++ b/custom/elpa-mirror.el @@ -1,4 +1,4 @@ -;;; elpa-mirror.el --- Create local package repository from installed packages +;;; elpa-mirror.el --- Create local package repository from installed packages -*- lexical-binding: t -*- ;; Copyright (C) 2014-2020 Chen Bin diff --git a/docker/telega-server/Dockerfile b/docker/telega-server/Dockerfile new file mode 100644 index 00000000..6bd2c579 --- /dev/null +++ b/docker/telega-server/Dockerfile @@ -0,0 +1,16 @@ +# telega-server image for modules/telega-config.el. Build with `make telega-image'. +# +# Upstream's zevlg/telega-server:latest ships tdlib 1.8.66 (the floor the +# current telega package demands) but its telega-server binary fails to start: +# libgdk_pixbuf needs libglycin-2.so.0 and the image doesn't carry it. Known +# open bug: https://github.com/zevlg/telega.el/issues/596. This derived image +# adds the one missing package and nothing else. +# +# The base is pinned by digest, not tag, so a rebuild on another machine gets +# the same upstream layers. libglycin itself is deliberately not version +# pinned: Alpine's repos keep only the current build of a package, so an exact +# `libglycin=X-rN' fails the build the day it rotates, which is worse than one +# layer differing between machines. When #596 is fixed upstream, point +# `cj/telega-docker-image' back at a registry digest and delete this file. +FROM zevlg/telega-server@sha256:aa7e79c4e9587c84065782df9399653fb1a967078b08ec1ded77738d4c2d70ad +RUN apk add --no-cache libglycin diff --git a/docs/design/2026-08-03-ambience-audio-handoff.org b/docs/design/2026-08-03-ambience-audio-handoff.org new file mode 100644 index 00000000..045e44ad --- /dev/null +++ b/docs/design/2026-08-03-ambience-audio-handoff.org @@ -0,0 +1,79 @@ +#+TITLE: Ambience audio — build notes and source findings +#+AUTHOR: Craig Jennings +#+DATE: 2026-08-03 + +Build notes for the ambient audio the music config plays. The audio itself +is not tracked here; it lives at =~/documents/sounds/ambience/= and the +playlist reaches it by relative path. This file is the technique and the +measurements, which are the parts worth keeping. + +* What these are + +Three 1-hour ambient tracks built 2026-08-03: + + cafe-1h 29 MB cafe murmur only + rain-1h 25 MB rain only + rain-plus-cafe65-1h 43 MB both, cafe at 65% of the rain + +* How they were built + +Sources are two short loops — cafe at 1:50 and rain at 2:32, both 24 kHz +stereo at 56-64 kbps. + +The two pure tracks are =ffmpeg -stream_loop= with =-c copy=, so they carry +no second-generation encoding loss: bit-identical to the source repeated +about thirty times. Only the mix is re-encoded (libmp3lame 96k, 24 kHz to +match source). + +The mix is rain at unity and cafe at =volume=0.65=, combined with +=amix=normalize=0=. + +*The =normalize=0= is the part to remember.* =amix= normalizes by default, +which halves both inputs and throws the 65% ratio away — the thing you were +setting is silently discarded and the output still sounds plausible. + +Verified after building: peak -1.1 dBTP (no clipping), mean -23.3 dB. + +=cafe-1h= is 3599.26s rather than 3600 because a stream copy cuts on an MP3 +frame boundary. I took the lossless copy over the last 0.74s. + +* A better-sounding source set exists + +There is also a set built from openly-licensed field recordings, at +=~/documents/sounds/ambience/cc0-*.mp3= — rain from "Lluvia En Riumors" +(CC0 1.0, 18:08, lossless FLAC source) and cafe from "Cafe, Aldeburgh, UK" +via radio aporee (Public Domain Mark 1.0, 17:33, 320 kbps). + +They sound better than the short loops for a structural reason: 44.1 kHz +throughout, and an hour needs about four passes rather than thirty, so there +is far less audible repetition. + +** Open thread — that set's rain is too percussive + +It was recorded on hard pavement, so you hear drop impacts you would never +hear from inside a cafe. + +Measured: its energy above 2 kHz sits only 0.4 dB below full-band, against +-19.9 dB for a real rain-through-a-window recording. + +Filtering the pavement rain to match does not work — it strips to sparse +thumps, because that recording's rain character lives almost entirely above +1 kHz. The fix is a different source recorded indoors, which is unresolved. + +Relevant if a rain-only mode ever gets built. + +* Note on the loop periods + +Measured separately when the 15-minute loops were cut: the periods are exact +rather than estimated, because the files are literal stream-copy repeats, so +the period is found by locating where the byte stream repeats. cafe is +109.680s (4570 frames), rain is 151.584s (6316 frames). + +gcd(4570, 6316) = 2 frames, so the two layers coincide only every 14,432,060 +frames — 96.2 hours. No practical length wraps both cleanly, which is why the +15-minute mix uses a 3s equal-power (qsin) crossfade folding its tail over its +head so F(0) = F(L), rather than a naive cut. + +Measured across the wrap against the typical adjacent sample step inside the +file: a naive 900s cut gives 4875 against 248 (19.7x, an audible click); the +crossfaded version gives 236 against 229 (1.03x). diff --git a/docs/design/2026-08-23-telega-docker-pin-tdlib-mismatch.org b/docs/design/2026-08-23-telega-docker-pin-tdlib-mismatch.org new file mode 100644 index 00000000..6428e8c1 --- /dev/null +++ b/docs/design/2026-08-23-telega-docker-pin-tdlib-mismatch.org @@ -0,0 +1,261 @@ +#+TITLE: telega-server is dead on velox: the docker image pin went stale when the package updated +#+AUTHOR: Craig Jennings +#+DATE: 2026-08-23 + +* Summary + +Telegram has been an unscannable channel on velox since 2026-08-19. Two triage +sweeps (08-21 and 08-23) recorded it as a scan failure and both blamed a missing +docker image. That diagnosis was wrong. The real cause is a version mismatch +between =modules/telega-config.el='s digest pin and the telega package MELPA +installed on 2026-08-18. It is reproducible, it is silent, and ratio is one +package upgrade from the same failure. + +Everything below was measured on velox on 2026-08-23, with ratio checked over +tailscale for comparison. + +* What actually happens + +=telega-server= starts fine. The container runs, tdlib initialises, and telega.el +completes a handshake with it: the server log shows five =setOption= requests +arriving from telega.el (language, =use_storage_optimizer=, =ignore_file_names=). +About eleven milliseconds later telega.el sends =close= and the client unwinds +cleanly: requests aborted, =authorizationStateClosing=, +=authorizationStateClosed=, =Td::hangup=, =Stop Td=. + +The trigger is in =telega-tdlib-events.el= around line 1306. When tdlib reports +its =:version= option, telega compares it against =telega-tdlib-min-version= and, +if the server is older, does this: + +#+begin_src emacs-lisp +(warn version-error-msg) +;; Finally stop processing events from telega-server +(telega-server-kill) +(error version-error-msg) +#+end_src + +The numbers: + +| where | value | +|----------------------------------------------------+--------| +| tdlib in the pinned image | 1.8.64 | +| =telega-tdlib-min-version= in telega-20260817.621 | 1.8.66 | + +1.8.64 < 1.8.66, so telega kills its own server on every launch. + +* The timeline is exact + +- =elpa/telega-20260817.621/= is dated 2026-08-18 11:14. The package updated, + and that build raised =telega-tdlib-min-version= from 1.8.64 to 1.8.66. +- =~/.telega/telega-server.log= holds at least six launch attempts across + 2026-08-19 15:20, 08-20 10:50, 08-21 15:10 and 08-23 10:50 (the count grows by + one each time I reproduce it). Every one reaches + =authorizationStateWaitTdlibParameters= and then closes. Not one ever reaches + =WaitPhoneNumber=, let alone Ready. +- The first failure is the day after the package update. Nothing else changed. + +The digest pin is +=zevlg/telega-server@sha256:a4b88e029ba381eca7c37c9618c9e3ad73aa9db2097fe07a0c6684d40d32b84e=, +an image built 2026-06-05. It was correct for the July package and is wrong for +this one. + +* Two things I got wrong first, worth recording + +The image is present. I reported it missing on 08-21 and again on 08-23, on the +strength of =docker images= showing only the slack-mcp container. That output +lies here: the newer docker CLI's default listing (the =IMAGE / DISK USAGE / +CONTENT SIZE= format) only shows tagged images, and an image pulled by digest has +no =RepoTags=. =docker images -a --digests= shows it plainly: + +: zevlg/telega-server <none> sha256:a4b88e02... db0e011ad225 2 months ago 312MB + +If a probe needs to know whether an image is on a machine, =docker image inspect +<ref>= is the honest check. =docker images= isn't. + +The image also works. I ran the exact command telega builds +(=telega-docker-run-cmd=) by hand. tdlib 1.8.64 came up, created a client, and sat +at =authorizationStateWaitTdlibParameters= waiting for telega.el, which is +correct behaviour. There's nothing wrong with the container. + +* Why nothing told me, and what I still don't know about that + +I first wrote this up as "the death alert is structurally unable to fire because +=telega-server-kill= is orderly, so the exit status is zero." That was wrong, and +the evidence that refutes it was already in front of me: the daemon's +=*Messages*= holds =[125]telega-server: exited abnormally with code 125=, and +=telega-server--sentinel= prints that line only from its non-zero-exit branch. +=telega-server-kill= works by killing the process buffer, not by a clean close, +so the process exits 125. =cj/--telega-server-death-p= returns t for any non-zero +integer, and the =:after= advice on the sentinel then runs +=notify fail "Telegram: telega-server died" ... --persist=. + +So the notification path was armed and should have paged me on every one of +those launches. I didn't see one. I can't reconstruct why from here: the +daemon's process table from those days is gone, so whether =notify= ran and I +dismissed it, or the =notify= script was absent in the days after the 08-13 +rebuild, or the advice hadn't been installed in that daemon, is unmeasured. +Worth a controlled reproduction with the daemon watched, rather than another +guess. + +Two things did fail as described. The =(warn ...)= goes to =*Warnings*=, which I +never look at in a daemon driven by =emacsclient=. And =(telega t)= still returns +=started= regardless, so a caller checking the return value learns nothing; only +=(telega-server-live-p)= a moment later tells the truth. + +* ratio is fine today and breaks on its next package upgrade + +| | velox | ratio | +|------------------------------------------------+---------------------+----------------------| +| telega package | telega-20260817.621 | telega-20260706.2147 | +| =telega-tdlib-min-version= | 1.8.66 | 1.8.64 | +| pinned image (a4b88e, tdlib 1.8.64) | present | present | +| =zevlg/telega-server:latest= (aa7e79c4) | absent (pulled later, see below) | present | +| =~/.telega/td.binlog= | absent | 1.5 MB, written 08-16 | +| =~/.telega/db.sqlite= | absent | 14.7 MB | + +ratio's package still wants 1.8.64, which is exactly what the pinned image +carries, which is why Telegram still works there. It's one =package-upgrade +telega= away from the identical silent failure. Worth fixing before that happens +rather than after. + +* Second, separate problem on velox: there is no Telegram session + +=~/.telega/= on velox holds only an empty =cache/= and =temp/=, both dated +2026-08-19 15:26, the first failed attempt. No =td.binlog=, no =db.sqlite=. The +account state was lost in the 2026-08-13 rebuild and never restored (the same +rebuild that wiped the Signal identity, which I recovered from the pre-reinstall +backup). + +So fixing the image pin gets telega to start on velox. It will then sit at +=WaitPhoneNumber= and need interactive auth (phone number plus verification code) +inside =M-x telega=. That can't be done headlessly. The pre-reinstall backup is +worth checking for =~/.telega= before re-authing from scratch, since restoring +the binlog would keep the existing session rather than minting a new device. + +* The obvious fix doesn't work + +The mechanical fix would be to move =cj/telega-docker-image= to a digest whose +tdlib is >= 1.8.66. The obvious candidate is =zevlg/telega-server:latest=, which +ratio already holds at +=sha256:aa7e79c4e9587c84065782df9399653fb1a967078b08ec1ded77738d4c2d70ad=. + +I read the tdlib version straight out of the shared library in both images on +ratio, where both are present: + +| image | libtdjson | +|------------------------+-----------------------| +| =a4b88e02= (pinned) | =libtdjson.so.1.8.64= | +| =aa7e79c4= (=:latest=) | =libtdjson.so.1.8.66= | + +The version floor is satisfied by =:latest=, but the image is broken: +=docker run --rm zevlg/telega-server:latest telega-server -h= exits 127 with 32 +lines of linker failure, beginning + +: Error loading shared library libglycin-2.so.0: No such file or directory (needed by /usr/lib/libgdk_pixbuf-2.0.so.0) + +It reproduced identically on velox after I pulled the image there, so it's the +image and not one machine. My first read blamed the failure on having overridden +the container entrypoint. That's not it: the image has no entrypoint +(=ENTRYPOINT=null=, =CMD=["/bin/bash"]=), and the same invocation against the +pinned image runs and prints =Version 1.2.0, with appindicator, with zlib=. + +** It's a known, open upstream bug + +[[https://github.com/zevlg/telega.el/issues/596][zevlg/telega.el issue #596]], +"docker image zevlg/telega-server:latest missing libglycin (-2.so.0)", opened +2026-08-11 by akovalenko. Still open, no maintainer response, no official fix. + +Docker Hub carries only three tags for =zevlg/telega-server=: =latest= (pushed +2026-07-23, digest =aa7e79c4=), =arm64= (2025-02-03) and =1.8.0= (2021-12-31). +So there's no =1.8.66= tag to pin to instead, and "pin to latest" and "pin to the +broken image" are the same action. + +** The workaround works, verified locally + +The two-line derived image from issue #596: + +#+begin_src dockerfile +FROM zevlg/telega-server:latest +RUN apk add --no-cache libglycin +#+end_src + +Built on velox as =telega-server-glycin:test=: + +- =apk add libglycin= resolves cleanly (150 packages, 155.6 MiB). +- =telega-server -h= prints =Version 1.2.0, with appindicator, with zlib=. It runs. +- =/usr/lib/libtdjson.so.1.8.66=, satisfying telega-20260817.621's floor. + +* What remains a decision rather than a measurement + +1. A locally-built image has no =RepoDigest=, so =cj/telega-docker-image= would + degrade from a digest pin to a tag reference, losing the guarantee that pin + exists to give. +2. It's fleet-local. ratio needs the same image built there (or a registry to + pull from), or it breaks on its next =package-upgrade telega=. +3. The alternative is pinning the telega package back to =20260706.2147=. That + keeps the working upstream image and the digest pin, and stops the + auto-upgrade that caused this, at the cost of freezing telega until #596 is + fixed. +4. Either way velox has no Telegram session, so it lands at =WaitPhoneNumber= + and needs interactive auth that can't be done headlessly. + +I haven't decided yet. Two related pieces of hardening are worth doing whichever +way it goes: + +- The pin's own docstring already ties it to "this telega's + =telega-tdlib-min-version=", so the coupling was understood, but nothing + enforces it and the package updates on its own schedule. A launch-time + assertion comparing the running server's reported tdlib version against + =telega-tdlib-min-version=, reported through =notify= rather than =warn=, + catches the whole class. =tests/test-telega-config--docker-pin.el= is the + natural home for a test that the pin and the installed package's floor agree. +- A controlled reproduction of the silent death with the daemon watched, to + find out why the armed notification wasn't seen (previous section). + +* Decision (2026-08-25): derived image, built from a Dockerfile in this repo + +I went with the derived image, in a form that keeps most of what the digest +pin gave. Three things settled it: + +- The derived image (tdlib 1.8.66) satisfies both machines' current packages: + velox's telega wants 1.8.66 and ratio's wants 1.8.64, and telega accepts + anything at or above its floor. The package pin would have worked only on + velox, and only after copying =elpa/telega-20260706.2147= over from ratio. +- package.el has no version pin and MELPA serves only its latest build, so + "pin the package back" is a copied directory plus the hope that nobody runs + =package-upgrade= again. Nothing enforces it. +- The pre-reinstall backup on the NAS holds velox's =~/.telega= (td.binlog + and db.sqlite from 2026-07-05), so a working image plus that directory may + restore the session without a phone re-auth. + +The shape: =docker/telega-server/Dockerfile= (FROM pinned to the upstream +digest, plus =apk add libglycin=), =make telega-image= builds it under +=cj/telega-server:1.8.66-glycin=, =cj/telega-docker-image= defaults to that +tag, and =cj/telega= refuses to launch with a "run make telega-image" message +when the image isn't built, so a fresh machine gets a pointer instead of a +confusing registry pull failure. The digest guarantee lives in the +Dockerfile's FROM line; a test holds the defcustom default equal to the +Makefile's tag. When #596 is fixed upstream, the pin goes back to a registry +digest and the Dockerfile goes. + +Not done here: the launch-time tdlib-version assertion, and the controlled +reproduction of the unseen death notification. Both are filed. + +* Reproducing it + +#+begin_src sh +# the image is there, despite what `docker images` shows +docker images -a --digests | grep telega +docker image inspect zevlg/telega-server@sha256:a4b88e029ba381eca7c37c9618c9e3ad73aa9db2097fe07a0c6684d40d32b84e >/dev/null && echo present + +# the version floor vs what the image ships +grep -E 'defconst telega-tdlib-(min|max)-version' ~/.emacs.d/elpa/telega-*/telega.el + +# repeated identical failures, no Ready among them +grep -c 'authorizationStateClosed' ~/.telega/telega-server.log +grep 'Receive request 6: close' ~/.telega/telega-server.log + +# the broken upstream image, and the derived one that works +docker run --rm zevlg/telega-server:latest telega-server -h; echo "exit $?" +docker run --rm telega-server-glycin:test telega-server -h; echo "exit $?" +#+end_src diff --git a/docs/specs/2026-07-06-radio-browser-lookup-spec.org b/docs/specs/2026-07-06-radio-browser-lookup-spec.org index c65de850..89251418 100644 --- a/docs/specs/2026-07-06-radio-browser-lookup-spec.org +++ b/docs/specs/2026-07-06-radio-browser-lookup-spec.org @@ -162,7 +162,7 @@ Add cj/music-radio-search (query -> search -> completing-read multi-select -> wr * Readiness dimensions - Data model & ownership: a station plist (uuid, name, url, codec, bitrate, tags, country, votes, clickcount) derived from the API; the .m3u file is generated and owned by Craig once written. No local cache in v1. -- Errors, empty states & failure: named user-errors — no server reachable, empty results, cancelled selection, write failure (naming the file). No silent data loss; overwrite reuses the existing cj/confirm-strong prompt from create-radio-station. +- Errors, empty states & failure: named user-errors — no server reachable, empty results, cancelled selection, write failure (naming the file). No silent data loss; overwrite reuses the existing cj/confirm-destructive prompt from create-radio-station. - Security & privacy: no credentials. The only outbound data is the search query and a User-Agent to a public API. No sensitive data logged. - Observability: the command messages the server used, the result count, and each file written. Search is one short synchronous call; if it ever feels slow, a "Searching radio-browser…" message covers it. - Performance & scale: result sets bounded by an explicit limit (default ~30). One GET per search. No scaling concern. diff --git a/docs/specs/2026-07-17-org-agenda-fullscreen-frame-spec.org b/docs/specs/2026-07-17-org-agenda-fullscreen-frame-spec.org index 567da53b..497131dc 100644 --- a/docs/specs/2026-07-17-org-agenda-fullscreen-frame-spec.org +++ b/docs/specs/2026-07-17-org-agenda-fullscreen-frame-spec.org @@ -4,10 +4,11 @@ #+TODO: TODO | DONE #+TODO: DRAFT READY DOING | IMPLEMENTED SUPERSEDED CANCELLED -* IMPLEMENTED org-agenda fullscreen frame +* SUPERSEDED org-agenda fullscreen frame :PROPERTIES: :ID: 7705c94b-9bb7-47d8-9828-e9584172c54f :END: +- 2026-07-27 Mon @ 13:57 -0500 — SUPERSEDED. Craig replaced the whole design with a separate Emacs process that shows the agenda, toggles fullscreen on a key, and refreshes itself every five minutes. This reverses the "Not a separate OS process" non-goal below: the daemon frame bought live shared state, but paid for it with a default-deny read-only policy, engage-routing, auto-dim suspension, and a marker-cloning failure path — machinery that only existed because the agenda shared a process with the working frames. A separate process needs none of it. =modules/org-agenda-frame.el= and its two test files were deleted and =S-<f8>= returned to =cj/org-agenda-refresh-files=. - 2026-07-20 Mon @ 15:33 -0500 — post-implementation correction: dropped =(fullscreen . fullboth)= from the spawned frame. Craig's "fullscreen" meant a normal frame at its full tiled position, not a compositor-wide fullscreen; the frame is now a plain =make-frame= that a tiling WM (Hyprland) places side by side with the working frame. The engage-routing and focus logic are unchanged and now matter more (open a task in the adjacent working pane). The spec's "fullscreen" wording and filename are retained as historical; read them as "dedicated tiled frame". Covered by =test-org-agenda-frame-parameters-normal-tiled-frame=. - 2026-07-20 Mon @ 14:10 -0500 — IMPLEMENTED. Built both phases in =modules/org-agenda-frame.el= (58 ERT tests, full suite green, byte-compile clean, full init loads clean, live-reloaded into the daemon with all wiring confirmed). Phase 1: frame lookup/predicate/working-frame routing, the =F= today-anchored 7-day view + registration, the default-deny =cj/agenda-frame-mode= (allowlist + two message classes + menu removal + finalize re-enable), transactional spawn/raise/delete/toggle, engage routing, sticky/close lifecycle. Phase 2: the 5-min wall-clock =org-agenda-redo= timer with the window/focus contract, duplicate-timer prevention, deterministic point restoration, the frame-owned last-good snapshot with cloned markers + failure overlay + report-once latch, and the public =cj/agenda-frame-toggle= on =S-<f8>= with the force-rescan moved to =C-M-<f8>=. The compositor fullscreen/focus and real-redo behaviors are a residual manual check (VERIFY filed under Manual testing). - 2026-07-20 Mon @ 13:30 -0500 — DOING. Decomposed into build tasks (Phase 1, Phase 2, flip-to-IMPLEMENTED) under the fullscreen-frame PROJECT in todo.org; =:SPEC_ID:= stamped. Building Phase 1. @@ -27,7 +28,7 @@ - 2026-07-17 Fri @ 19:34:07 -0500 — drafted. * Metadata -| Status | implemented | +| Status | superseded | |----------+------------------------------------------------| | Owner | Craig Jennings | |----------+------------------------------------------------| diff --git a/early-init.el b/early-init.el index d59f0a8b..8d4eb268 100644 --- a/early-init.el +++ b/early-init.el @@ -253,6 +253,18 @@ early-init.el.") ;;(require 'use-package-ensure) ; Needed for :ensure to work (setq use-package-always-ensure t) ; Auto-install packages +;; A dead download must not abort startup. `use-package-ensure-elpa' already +;; warns and carries on when an install fails, but it guards with +;; `condition-case-unless-debug', which does nothing while `debug-on-error' is +;; set -- and it is set above, deliberately, so init errors are loud. The two +;; collide: one file-error from an ELPA host stopped a fresh install in place +;; with a third of the config loaded. This module takes over +;; `use-package-ensure-function' so the debugger is inhibited for the install +;; alone, retries a transient failure, and reports what is missing once startup +;; finishes. The load-path form matches init.el's so add-to-list dedups it. +(add-to-list 'load-path (concat user-emacs-directory "modules/")) +(require 'package-resilience) + ;; Keep the GNU ELPA signing keys current so signature verification doesn't ;; start failing when the archive key expires (the usual reason verification ;; gets turned off). Failure is non-fatal so a clean-machine bootstrap or an diff --git a/githooks/pre-commit b/githooks/pre-commit index a87bedf8..2be98c79 100755 --- a/githooks/pre-commit +++ b/githooks/pre-commit @@ -15,7 +15,12 @@ cd "$REPO_ROOT" || exit 1 # AKIA[0-9A-Z]{16} matches any mixed-case 20-char run, which random base64 in an # embedded image blob hits ~6% of the time per 100KB and blocks real commits. # Only the keyword=value patterns need -i. -SECRET_PATTERNS_CS='(AKIA[0-9A-Z]{16}|sk-[a-zA-Z0-9_-]{20,}|-----BEGIN (RSA|DSA|EC|OPENSSH|PGP)( PRIVATE)?( KEY| KEY BLOCK)?-----)' +# +# The sk- pattern is anchored on a word boundary: unanchored it matched inside +# any hyphenated identifier ending in sk- (task-, risk-, disk-) with 20 more +# word characters, which blocked a commit on an elisp assertion naming +# task-missing-last-reviewed. A real key always starts its token. +SECRET_PATTERNS_CS='(AKIA[0-9A-Z]{16}|\bsk-[a-zA-Z0-9_-]{20,}|-----BEGIN (RSA|DSA|EC|OPENSSH|PGP)( PRIVATE)?( KEY| KEY BLOCK)?-----)' SECRET_PATTERNS_CI='(api[_-]?key|api[_-]?secret|auth[_-]?token|secret[_-]?key|bearer[_-]?token|access[_-]?token|password)[[:space:]]*[:=][[:space:]]*["'"'"'][^"'"'"']{16,}["'"'"']' # Read the diff on its own so a git failure is distinguishable from "grep @@ -129,7 +129,7 @@ (require 'org-config) ;; basic org-mode settings (require 'org-faces-config) ;; custom themeable faces for agenda keywords + priorities (require 'org-agenda-config) ;; agenda, task tracking, and notifications -(require 'org-agenda-frame) ;; S-<f8> dedicated agenda frame (tiled beside the working frame) +(require 'agenda-query) ;; agenda window as JSON for external renderers (require 'org-babel-config) ;; org-mode prog blocks; literate programming (require 'org-capture-config) (require 'org-contacts-config) ;; fully integrated org-mode contacts management @@ -160,7 +160,12 @@ (require 'music-config) ;; games-config: deferred (load-graph Phase 4). malyon / 2048-game autoload ;; their own commands via package.el; games-config only supplies malyon's config, -;; so load it when malyon loads rather than requiring it at startup. +;; so load it when malyon loads rather than requiring it at startup. The two +;; use-package forms exist so `use-package-always-ensure' installs the packages +;; on a fresh machine: nothing else declares them, and a8571eff's removal left +;; both absent after the 2026-08-13 reinstall. :defer t keeps them unloaded. +(use-package malyon :defer t :commands (malyon)) +(use-package 2048-game :defer t :commands (2048-game)) (with-eval-after-load 'malyon (require 'games-config)) (require 'takuzu-config) ;; Takuzu (Binairo) puzzle on M-x takuzu; package in ~/code/takuzu diff --git a/modules/agenda-query.el b/modules/agenda-query.el new file mode 100644 index 00000000..c98b7fb7 --- /dev/null +++ b/modules/agenda-query.el @@ -0,0 +1,607 @@ +;;; agenda-query.el --- Agenda window as JSON for external renderers -*- lexical-binding: t; coding: utf-8; -*- +;; author: Craig Jennings <c@cjennings.net> +;; +;;; Commentary: +;; +;; Layer: 3 (Domain Workflow). +;; Category: D/S. +;; Load shape: eager module, lazy dependencies. +;; Eager reason: the entry point must exist for a headless emacsclient --eval. +;; Org is required at call time, so loading the BYTE-COMPILED module costs no +;; startup; loading it from source pays the eval-when-compile requires below. +;; Top-level side effects: none once compiled. +;; Runtime requires: org, org-element, org-agenda, calendar -- all deferred. +;; Direct test load: yes. +;; +;; Answers "what is on the agenda between these two instants" as JSON, so a +;; renderer running outside Emacs can draw it. Both entry points read +;; `org-agenda-files' and leave every buffer unmodified. +;; +;; Two output profiles over one query. `cj/agenda-window-json' is canonical: +;; epoch seconds, descriptive field names, and a null end where the source has +;; no range. `cj/agenda-render-json' adds what the wallpaper renderer reads -- +;; s and e in epoch MILLISECONDS, t for the title, and an end every row can +;; actually be drawn with. `cj/agenda-render-cache-update' writes that profile +;; for today to `cj/agenda-render-cache-file'. +;; +;; Epoch seconds at the boundary is the load-bearing interface choice. It takes +;; timezone out of the contract entirely: the consumer does its own zoneinfo +;; conversion, and nothing downstream needs to know org's timestamps are naive +;; local time. DST changeovers stop being a special case for the same reason. +;; +;; The window predicate is intersection, not containment: an event is in the +;; window when it is running at any point during it, so a 23:00-01:00 event +;; belongs to both days it touches. An all-day entry's extent is its whole day. + +;;; Code: + +;; Compile-time only, so the byte-compiler sees org's functions while a plain +;; load of this file still pulls in nothing. +(eval-when-compile + (require 'org) + (require 'org-element) + (require 'org-agenda) + (require 'calendar)) + +(declare-function org-element--property "org-element-ast") +(declare-function org-element-map "org-element") +(declare-function org-element-parse-buffer "org-element") +(declare-function org-element-type "org-element-ast") +(declare-function org-entry-get "org") +(declare-function org-agenda--timestamp-to-absolute "org-agenda") +(declare-function org-agenda-files "org") +(declare-function org-get-agenda-file-buffer "org") +(declare-function calendar-gregorian-from-absolute "calendar") +(declare-function calendar-absolute-from-gregorian "calendar") + +(defconst cj/agenda-query-max-window-seconds (* 366 24 60 60) + "Widest window `cj/agenda-window-json' will answer, in seconds. + +A guard against a units mistake rather than a policy limit. The consumers are +Python and JavaScript, and `Date.now' returns MILLISECONDS -- passing that +unconverted asks for a window tens of thousands of years wide, which builds +millions of rows and wedges the Emacs daemon Craig is working in. Failing +loudly costs a renderer one bad frame; the alternative costs him his editor.") + +(defconst cj/agenda-query-epoch-floor -2208988800 + "Earliest epoch second `cj/agenda-window-json' accepts (1900-01-01).") + +(defconst cj/agenda-query-epoch-ceiling 7258118400 + "Latest epoch second `cj/agenda-window-json' accepts (2200-01-01). + +Width alone does not catch the units mistake. Passing `Date.now()' for BOTH +bounds an hour apart is a plausible-looking 41-day window made of milliseconds, +which sails past the width cap and answers with timestamps in the year 58549. +Bounding the magnitude catches that shape, while still spanning any date an +agenda could legitimately hold.") + +(defun cj/--agenda-query-load-org () + "Load org at call time. +Kept off the top level so requiring this module costs nothing at startup -- +the entry point runs headless, long after Emacs is up. Idempotent." + (require 'org) + (require 'org-element) + (require 'org-agenda) + (require 'calendar)) + +;;; ---------- time helpers ---------- + +(defun cj/--agenda-query-epoch (sec min hour day month year) + "Return the epoch second for local time SEC MIN HOUR DAY MONTH YEAR. +Out-of-range fields normalize, so day 32 of July is the 1st of August." + (time-convert (encode-time (list sec min hour day month year nil -1 nil)) + 'integer)) + +(defun cj/--agenda-query-day-close (day month year) + "Return the last epoch second of the local day DAY MONTH YEAR. +Reached through the following midnight rather than by adding 86400, so a DST +changeover day is 23 or 25 hours long as it actually is." + (1- (cj/--agenda-query-epoch 0 0 0 (1+ day) month year))) + +(defun cj/--agenda-query-epoch-to-absolute (epoch) + "Return the absolute day number containing EPOCH, in local time." + (let ((d (decode-time epoch))) + (calendar-absolute-from-gregorian (list (nth 4 d) (nth 3 d) (nth 5 d))))) + +(defun cj/--agenda-query-day-close-of (absolute) + "Return the last epoch second of the ABSOLUTE day number." + (let ((g (calendar-gregorian-from-absolute absolute))) + (cj/--agenda-query-day-close (nth 1 g) (nth 0 g) (nth 2 g)))) + +(defun cj/--agenda-query-at-time-on (absolute hour minute) + "Return the epoch of HOUR:MINUTE local on the ABSOLUTE day number." + (let ((g (calendar-gregorian-from-absolute absolute))) + (cj/--agenda-query-epoch 0 minute hour (nth 1 g) (nth 0 g) (nth 2 g)))) + +;;; ---------- timestamp bounds ---------- + +(defun cj/--agenda-query-timestamp-bounds (timestamp) + "Return a bounds plist for org-element TIMESTAMP, or nil when it is nil. + +Keys are :start, :end, :all-day and :effective-end, all epoch seconds except +:all-day. :end is nil when the source carries no range at all; where the +source does carry one, an all-day range's end is the close of its last day, +since a day is its own extent. :effective-end is what the window predicate +uses: the explicit end, or an all-day entry's day close, or a timed point +event's own instant. + +One deliberate divergence from org's literal parse: org records +<2026-07-31 Fri 23:00-01:00> with its end on the SAME day, which would put the +end 22 hours before the start. A negative duration is useless to any +consumer, so an end that precedes its start is read as crossing midnight." + (when timestamp + (let* ((y0 (org-element-property :year-start timestamp)) + (m0 (org-element-property :month-start timestamp)) + (d0 (org-element-property :day-start timestamp)) + (h0 (org-element-property :hour-start timestamp)) + (mi0 (org-element-property :minute-start timestamp)) + (y1 (org-element-property :year-end timestamp)) + (m1 (org-element-property :month-end timestamp)) + (d1 (org-element-property :day-end timestamp)) + (h1 (org-element-property :hour-end timestamp)) + (mi1 (org-element-property :minute-end timestamp)) + (all-day (null h0)) + (start (cj/--agenda-query-epoch 0 (or mi0 0) (or h0 0) d0 m0 y0)) + (ranged (or (not (equal (list y0 m0 d0) (list y1 m1 d1))) + (and h1 (not (equal (list h0 mi0) (list h1 mi1)))))) + (same-day (equal (list y0 m0 d0) (list y1 m1 d1))) + (end (when ranged + (if all-day + ;; A reversed all-day range (a typo, or a bad ICS + ;; import) would otherwise report an end days before + ;; its start, and the negative extent would drop the + ;; entry from the very window it opens in. + (let ((e (cj/--agenda-query-day-close d1 m1 y1))) + (and (>= e start) e)) + (let ((e (cj/--agenda-query-epoch + 0 (or mi1 0) (or h1 0) d1 m1 y1))) + ;; Roll only a SAME-DAY range: that is the shape org + ;; records for <23:00-01:00>. Rolling a genuinely + ;; reversed multi-day range would just shift a wrong + ;; date by a day and leave it wrong. + (when (and same-day (< e start)) + (setq e (cj/--agenda-query-epoch + 0 (or mi1 0) (or h1 0) (1+ d1) m1 y1))) + ;; A range that still ends before it starts is + ;; malformed. Report the entry as a point rather than + ;; hand a consumer a negative-duration bar. + (and (>= e start) e)))))) + (list :start start + :end end + :all-day (and all-day t) + :effective-end (or end + (if all-day + (cj/--agenda-query-day-close d0 m0 y0) + start)))))) + +(defun cj/--agenda-query-repeater-cookie (timestamp) + "Return TIMESTAMP's raw repeater cookie as a string, or nil when it has none." + (when timestamp + (let ((type (org-element-property :repeater-type timestamp)) + (value (org-element-property :repeater-value timestamp)) + (unit (org-element-property :repeater-unit timestamp))) + (when (and type value unit) + (concat (pcase type + ('cumulate "+") + ('catch-up "++") + ('restart ".+") + (_ "+")) + (number-to-string value) + (pcase unit + ('hour "h") ('day "d") ('week "w") + ('month "m") ('year "y") (_ ""))))))) + +;;; ---------- window intersection and repeat expansion ---------- + +(defun cj/--agenda-query-intersects-p (start effective-end win-start win-end) + "Return non-nil when START..EFFECTIVE-END overlaps WIN-START..WIN-END." + (and (>= effective-end win-start) + (<= start win-end))) + +(defun cj/--agenda-query-occurrence-on (day base bounds) + "Return the (START . END) cons and effective end for an occurrence on DAY. + +DAY is an absolute day number, BASE the base occurrence's own absolute day, +and BOUNDS its `cj/--agenda-query-timestamp-bounds' plist. Returns a plist +of :start, :end and :effective-end. + +Every field is rebuilt from calendar dates rather than by adding the base's +duration in seconds. A fixed offset is wrong across a DST boundary: an +all-day occurrence on a 25-hour day would end an hour early, and on a 23-hour +day it would spill into the next." + (let* ((start (plist-get bounds :start)) + (end (plist-get bounds :end)) + (all-day (plist-get bounds :all-day)) + (decoded (decode-time start)) + (span (if end + (- (cj/--agenda-query-epoch-to-absolute end) base) + 0)) + (occ-start (cj/--agenda-query-at-time-on + day (nth 2 decoded) (nth 1 decoded))) + (occ-end (when end + (if all-day + (cj/--agenda-query-day-close-of (+ day span)) + (let ((de (decode-time end))) + (cj/--agenda-query-at-time-on + (+ day span) (nth 2 de) (nth 1 de))))))) + (list :start occ-start + :end occ-end + :effective-end (or occ-end + (if all-day + (cj/--agenda-query-day-close-of day) + occ-start))))) + +(defun cj/--agenda-query-repeat-occurrences (timestamp bounds win-start win-end) + "Return every occurrence of repeating TIMESTAMP inside the window. + +BOUNDS is its `cj/--agenda-query-timestamp-bounds' plist. Each candidate day +is offered to `org-agenda--timestamp-to-absolute', which is org's own repeater +arithmetic -- so an occurrence lands exactly where Craig's agenda shows it +rather than where a reimplementation would put it. A day is an occurrence +when org maps it to itself. + +All three repeater styles expand from the base timestamp, including `.+': +org rewrites a restart repeater's base when the task is completed, so for an +open task the base already IS the last repeat. + +The scan starts before the window by the event's own day span, so an +occurrence that began earlier and is still running is found -- the same +intersects-not-contains rule the non-repeating path follows. + +Repeats are resolved at day granularity, matching org's agenda: an hourly +repeater therefore contributes one row per day rather than one per hour. + +Returns one cons per occurrence, oldest first. One row per occurrence is +deliberate -- a count is derivable from rows, rows are not derivable from a +count." + (cj/--agenda-query-load-org) + (let* ((raw (org-element-property :raw-value timestamp)) + (start (plist-get bounds :start)) + (end (plist-get bounds :end)) + (base-day (cj/--agenda-query-epoch-to-absolute start)) + (span (if end + (- (cj/--agenda-query-epoch-to-absolute end) base-day) + 0)) + (first-day (- (cj/--agenda-query-epoch-to-absolute win-start) + (1+ (max span 0)))) + (last-day (cj/--agenda-query-epoch-to-absolute win-end)) + (results '())) + (dotimes (offset (max 0 (1+ (- last-day first-day)))) + (let* ((day (+ first-day offset)) + (hit (when (>= day base-day) + (catch :skip + (org-agenda--timestamp-to-absolute raw day 'future))))) + (when (and (integerp hit) (= hit day)) + (let ((occ (cj/--agenda-query-occurrence-on day base-day bounds))) + (when (cj/--agenda-query-intersects-p + (plist-get occ :start) (plist-get occ :effective-end) + win-start win-end) + (push (cons (plist-get occ :start) (plist-get occ :end)) + results)))))) + (nreverse results))) + +(defun cj/--agenda-query-occurrences (timestamp win-start win-end) + "Return TIMESTAMP's (START . END) epoch conses inside the window. +END is nil for an occurrence the source gave no range. A non-repeating +timestamp yields at most one cons; a repeating one yields every occurrence." + (let ((bounds (cj/--agenda-query-timestamp-bounds timestamp))) + (when (and bounds (<= win-start win-end)) + (if (cj/--agenda-query-repeater-cookie timestamp) + (cj/--agenda-query-repeat-occurrences timestamp bounds win-start win-end) + (when (cj/--agenda-query-intersects-p (plist-get bounds :start) + (plist-get bounds :effective-end) + win-start win-end) + (list (cons (plist-get bounds :start) (plist-get bounds :end)))))))) + +;;; ---------- collecting events from a buffer ---------- + +(defun cj/--agenda-query-ancestor-headline (element) + "Return the nearest headline ancestor of ELEMENT, or nil when there is none." + (let ((node element)) + (while (and node (not (eq (org-element-type node) 'headline))) + (setq node (org-element-property :parent node))) + node)) + +(defun cj/--agenda-query-visible-p (headline) + "Return non-nil unless HEADLINE sits in an archived or commented subtree. + +Org's agenda skips both, and this query is only useful to the extent it +agrees with the agenda Craig actually sees. Ancestors count: archiving or +commenting a parent takes its whole subtree off the agenda." + (let ((node headline) + (visible t)) + (while (and node visible) + (when (eq (org-element-type node) 'headline) + (when (or (org-element-property :archivedp node) + (org-element-property :commentedp node)) + (setq visible nil))) + (setq node (org-element-property :parent node))) + visible)) + +(defun cj/--agenda-query-active-p (timestamp) + "Return non-nil when TIMESTAMP is active -- the kind org agendas show. +Inactive stamps and diary sexps are excluded: the first never reaches an +agenda, and the second cannot be reduced to a plain instant." + (memq (org-element-property :type timestamp) '(active active-range))) + +(defun cj/--agenda-query-title (headline) + "Return HEADLINE's title as display text. + +`:raw-value' already drops the keyword, priority cookie and tags, but keeps +org link syntax verbatim -- a captured web item arrives as +\"[[https://…][Tracking your habits]]\". Org's own agenda shows the +description, and a renderer has no business parsing org markup, so the link +is reduced here." + (let ((raw (or (org-element-property :raw-value headline) ""))) + (if (fboundp 'org-link-display-format) + (org-link-display-format raw) + raw))) + +(defun cj/--agenda-query-event (headline file type timestamp occurrence) + "Build one JSON-ready event alist. +HEADLINE supplies the title and completion state, FILE the source path, TYPE +the string \"scheduled\", \"deadline\" or \"timestamp\", TIMESTAMP the repeater +cookie, and OCCURRENCE the (START . END) epochs this row renders." + (let* ((begin (org-element-property :begin headline)) + (keyword (org-element-property :todo-keyword headline)) + (location (org-entry-get begin "LOCATION")) + (organizer (org-entry-get begin "ORGANIZER")) + (repeater (cj/--agenda-query-repeater-cookie timestamp)) + (bounds (cj/--agenda-query-timestamp-bounds timestamp))) + ;; Keys are symbols because `json-serialize' requires that of an alist. + (list (cons 'title (cj/--agenda-query-title headline)) + (cons 'start (car occurrence)) + (cons 'end (or (cdr occurrence) :null)) + (cons 'all-day (if (plist-get bounds :all-day) t :false)) + (cons 'type type) + (cons 'file file) + (cons 'keyword (or keyword :null)) + (cons 'done (if (eq (org-element-property :todo-type headline) 'done) + t :false)) + (cons 'repeater (or repeater :null)) + (cons 'location (or location :null)) + (cons 'organizer (or organizer :null))))) + +(defun cj/--agenda-query-collect (headline file type timestamp win-start win-end) + "Return every event row TIMESTAMP contributes, or nil." + (when (and timestamp + (cj/--agenda-query-active-p timestamp) + (cj/--agenda-query-visible-p headline)) + (mapcar (lambda (occurrence) + (cj/--agenda-query-event headline file type timestamp occurrence)) + (cj/--agenda-query-occurrences timestamp win-start win-end)))) + +(defun cj/--agenda-query-buffer-events (buffer file win-start win-end) + "Return the event rows BUFFER contributes for the window, tagged with FILE. + +Reads three kinds of timestamp, because org stores them two different ways. +SCHEDULED and DEADLINE are properties on the entry's `planning' element, NOT +children in the parse tree -- so the obvious implementation, mapping over +\\='timestamp, silently returns neither. It does not error; it just omits the +two entry kinds an agenda is mostly made of. Do not simplify this back into a +single `org-element-map' over \\='timestamp. Body timestamps are collected +separately, skipping any whose parent is a planning element so nothing is +counted twice." + (cj/--agenda-query-load-org) + (with-current-buffer buffer + (let ((tree (org-element-parse-buffer)) + (events '())) + ;; SCHEDULED and DEADLINE, read off the planning element. + (dolist (planning (org-element-map tree 'planning #'identity)) + (let ((headline (cj/--agenda-query-ancestor-headline planning))) + (when headline + (dolist (spec (list (cons "scheduled" :scheduled) + (cons "deadline" :deadline))) + (setq events + (nconc events + (cj/--agenda-query-collect + headline file (car spec) + (org-element-property (cdr spec) planning) + win-start win-end))))))) + ;; Plain active timestamps in entry bodies. + (dolist (timestamp (org-element-map tree 'timestamp #'identity)) + (unless (eq (org-element-type (org-element-property :parent timestamp)) + 'planning) + (let ((headline (cj/--agenda-query-ancestor-headline timestamp))) + (when headline + (setq events + (nconc events + (cj/--agenda-query-collect + headline file "timestamp" timestamp + win-start win-end))))))) + events))) + +;;; ---------- output ---------- + +(defun cj/--agenda-query-sort (events) + "Return EVENTS ordered by start, then title, so output is deterministic." + (sort (copy-sequence events) + (lambda (a b) + (let ((sa (alist-get 'start a)) + (sb (alist-get 'start b))) + (if (= sa sb) + (string< (alist-get 'title a) (alist-get 'title b)) + (< sa sb)))))) + +(defun cj/--agenda-query-drawable-end (event) + "Return EVENT's end as something a renderer can draw, in epoch seconds. + +The canonical row reports a null end when the source has no range, which is +faithful but not drawable. Here an all-day entry's extent is its whole day and +a timed point event's is the instant itself, so every row has a width -- even +if that width is zero. Derived from the row, so this stays a pure function of +canonical output." + (let ((start (alist-get 'start event)) + (end (alist-get 'end event))) + (cond + ((integerp end) end) + ((eq t (alist-get 'all-day event)) + (let ((d (decode-time start))) + (cj/--agenda-query-day-close (nth 3 d) (nth 4 d) (nth 5 d)))) + (t start)))) + +(defun cj/--agenda-query-render-row (event) + "Return EVENT in the renderer's contract, adding s, e and t. + +The renderer reads s and e as epoch MILLISECONDS and t as the title; it takes +everything else and drops it before drawing. The canonical fields are kept +alongside rather than replaced, so one file serves both the renderer and any +consumer reading the documented shape. Milliseconds live only in s and e -- +`start' and `end' stay seconds, and the two never mix within a key." + (append (list (cons 's (* 1000 (alist-get 'start event))) + (cons 'e (* 1000 (cj/--agenda-query-drawable-end event))) + (cons 't (alist-get 'title event))) + event)) + +(defun cj/--agenda-query-write-atomically (path text) + "Write TEXT to PATH through a temp file and a rename, returning PATH. + +The rename is why this matters: the renderer reads on a timer, so a partially +written file would be a parse error on a live surface. Replacing the file in +one step also makes it its own cache -- when Emacs is down the reader still +gets the last good answer instead of a truncated one. + +The temp file is created 0600 by `make-temp-file', so the mode is reset after +the rename; otherwise a reader running as anyone else could not open it. The +mask is 666, not `default-file-modes' alone -- that is 777 minus the umask, so +using it directly would publish the JSON world-EXECUTABLE." + (let* ((path (expand-file-name path)) + (dir (file-name-directory path)) + (temp (make-temp-file (expand-file-name ".agenda-query-" dir)))) + (unwind-protect + (progn + (let ((coding-system-for-write 'utf-8)) + (write-region text nil temp nil 'silent)) + (rename-file temp path t) + (set-file-modes path (logand #o666 (default-file-modes))) + (setq temp nil)) + (when (and temp (file-exists-p temp)) + (delete-file temp))) + path)) + +(defun cj/agenda-window-json (start-epoch end-epoch &optional out-path) + "Return the agenda between START-EPOCH and END-EPOCH as a JSON string. + +Both bounds are epoch SECONDS, inclusive. An event is included when it is +running at any point in the window, so an event that started before +START-EPOCH counts while it is still in progress. + +Each element of the returned array carries: title (keyword, priority cookie +and tags already stripped), start, end (null when the source has no range), +all-day, type (\"scheduled\", \"deadline\" or \"timestamp\"), file, keyword, +done, repeater (the raw cookie, or null), location and organizer. Absent +values are JSON null rather than omitted, so the shape is stable to parse. + +A repeating entry contributes one row per occurrence inside the window. + +With OUT-PATH, also write the JSON there atomically, leaving the previous +contents intact if anything fails. Reads `org-agenda-files' and modifies no +buffer, so it is safe to call on a timer or over emacsclient --eval. + +Signals when either bound falls outside 1900-2200, or when the window is wider +than `cj/agenda-query-max-window-seconds'. Both checks exist to surface a +milliseconds-for-seconds mistake, which otherwise answers with dates in the +year 58549 or builds millions of rows." + (let ((json (json-serialize + (vconcat (cj/--agenda-query-events start-epoch end-epoch))))) + (when out-path + (cj/--agenda-query-write-atomically out-path json)) + json)) + +(defun cj/--agenda-query-events (start-epoch end-epoch) + "Return the sorted event rows between START-EPOCH and END-EPOCH. +Shared by both output profiles; the callers do their own writing." + (unless (numberp start-epoch) + (signal 'wrong-type-argument (list 'numberp start-epoch))) + (unless (numberp end-epoch) + (signal 'wrong-type-argument (list 'numberp end-epoch))) + (cj/--agenda-query-load-org) + (let* ((win-start (floor start-epoch)) + (win-end (floor end-epoch)) + (events '())) + (dolist (bound (list win-start win-end)) + (unless (and (>= bound cj/agenda-query-epoch-floor) + (<= bound cj/agenda-query-epoch-ceiling)) + (user-error + "Agenda bound %s is outside 1900-2200; expected epoch SECONDS (milliseconds?)" + bound))) + (when (> (- win-end win-start) cj/agenda-query-max-window-seconds) + (user-error + "Agenda window spans %d days; bounds are epoch SECONDS (milliseconds?)" + (/ (- win-end win-start) 86400))) + (when (<= win-start win-end) + (dolist (file (org-agenda-files)) + (when (file-readable-p file) + (let ((buffer (org-get-agenda-file-buffer file))) + (when buffer + (setq events + (nconc events + (cj/--agenda-query-buffer-events + buffer file win-start win-end)))))))) + (cj/--agenda-query-sort events))) + +(defconst cj/agenda-render-cache-file + (expand-file-name + "settings/agenda.json" + (let ((xdg (getenv "XDG_CACHE_HOME"))) + ;; An empty XDG_CACHE_HOME is set-but-useless; `or' would take it and + ;; resolve the whole path relative to whatever the cwd happens to be. + (if (and xdg (not (string-empty-p xdg))) + xdg + (expand-file-name ".cache" (or (getenv "HOME") "~"))))) + "Where the wallpaper renderer reads the day from. + +A stable path is load-bearing on both sides. Because the file is only ever +replaced by a rename, the renderer keeps drawing the last good answer while +Emacs is down, which makes this file its own cache.") + +(defun cj/agenda-render-json (start-epoch end-epoch &optional out-path) + "Return the agenda between START-EPOCH and END-EPOCH in the renderer's shape. + +Bounds are epoch SECONDS, as everywhere else here. Each row carries the +canonical fields plus the three the renderer reads: s and e as epoch +MILLISECONDS, and t as the title. The renderer works in milliseconds +throughout, and converting once here beats converting in three places there. + +Every row has a drawable e, even where the canonical end is null: an all-day +entry spans its day and a point event has zero width. See +`cj/--agenda-query-drawable-end'." + (let ((json (json-serialize + (vconcat (mapcar #'cj/--agenda-query-render-row + (cj/--agenda-query-events start-epoch + end-epoch)))))) + (when out-path + (cj/--agenda-query-write-atomically out-path json)) + json)) + +(defun cj/agenda-render-cache-update () + "Write the agenda around today to `cj/agenda-render-cache-file'. + +The window is three whole local days: yesterday's midnight through tomorrow's +day close. A consumer drawing a rolling window centred on now needs entries +from either side of midnight, and a single calendar day leaves it with nothing +to draw for the part of its span that falls outside today -- half the surface, +late in the evening. Three days covers any rolling span up to a full day +either way, and the consumer filters to what it actually draws. + +Day boundaries are computed rather than assumed, so the span is 71, 72 or 73 +hours across a DST changeover rather than a flat 72. Returns the path. + +Safe to call repeatedly and from a timer: it only reads org files, creates the +cache directory if needed, and replaces the file by rename, so a reader on its +own schedule never sees a partial write." + (interactive) + (let* ((d (decode-time (time-convert nil 'integer))) + (day (nth 3 d)) (month (nth 4 d)) (year (nth 5 d)) + ;; Out-of-range day fields normalize, so day 0 is last month's last + ;; day and day+1 rolls the month or year without special cases. + (start (cj/--agenda-query-epoch 0 0 0 (1- day) month year)) + (end (cj/--agenda-query-day-close (1+ day) month year))) + (make-directory (file-name-directory cj/agenda-render-cache-file) t) + (cj/agenda-render-json start end cj/agenda-render-cache-file) + (when (called-interactively-p 'interactive) + (message "Agenda render cache written to %s" cj/agenda-render-cache-file)) + cj/agenda-render-cache-file)) + +(provide 'agenda-query) +;;; agenda-query.el ends here diff --git a/modules/calendar-sync.el b/modules/calendar-sync.el index d504f246..5338e7d7 100644 --- a/modules/calendar-sync.el +++ b/modules/calendar-sync.el @@ -87,10 +87,22 @@ calendar feed URLs." "Sync interval in minutes. Default: 60 minutes (1 hour).") -(defvar calendar-sync-auto-start t - "Whether to automatically start calendar sync when module loads. -If non-nil, sync starts automatically when calendar-sync is loaded. -If nil, user must manually call `calendar-sync-start'.") +(defvar calendar-sync-auto-start nil + "Whether the editor arms its own periodic sync when this module loads. + +Off by default: the calendar-sync.timer systemd unit owns the schedule now, +running scripts/calendar-sync-run every ten minutes whether or not Emacs is +up. Leaving the in-editor timer armed as well would give two owners writing +the same org files and the same state file, with no coordination between +them. + +Set to t to hand the schedule back to the editor -- the deferred start at the +end of this file still works, and `calendar-sync-start' and +`calendar-sync-now' remain available on demand either way. + +The tradeoff this default accepts: a checkout whose timer has never been +enabled does not sync on its own. Enabling the unit is a one-time step per +machine, alongside symlinking it into ~/.config/systemd/user.") (defvar calendar-sync-user-emails '("craigmartinjennings@gmail.com" "craig.jennings@deepsat.com" "c@cjennings.net") @@ -215,16 +227,27 @@ calendar files do not block the interactive Emacs thread. Skips a calendar whose previous sync is still in flight, so a timer tick that fires before a slow fetch finishes does not launch a second overlapping sync for -the same calendar." +the same calendar. + +A synchronous failure is contained here and recorded against this calendar +alone. The async callbacks record their own failures, but they never run when +the error lands before a process starts -- resolving a `:secret-host' feed +reads authinfo.gpg, which signals outright on a cold gpg-agent. Uncontained, +that first error aborted the whole loop and the remaining calendars never +synced." (let ((name (plist-get calendar :name))) - (cond - ((calendar-sync--syncing-p name) - (calendar-sync--log-silently - "calendar-sync: [%s] sync already in flight; skipping overlapping tick" name)) - ((eq (plist-get calendar :fetcher) 'api) - (calendar-sync--sync-calendar-api calendar)) - (t - (calendar-sync--sync-calendar-ics calendar))))) + (if (calendar-sync--syncing-p name) + (calendar-sync--log-silently + "calendar-sync: [%s] sync already in flight; skipping overlapping tick" name) + (condition-case err + (if (eq (plist-get calendar :fetcher) 'api) + (calendar-sync--sync-calendar-api calendar) + (calendar-sync--sync-calendar-ics calendar)) + (error + (let ((reason (error-message-string err))) + (calendar-sync--log-silently + "calendar-sync: [%s] Sync error: %s" name reason) + (calendar-sync--mark-sync-failed name reason))))))) (defun calendar-sync--require-calendars () "Return non-nil if calendars are configured, else warn and return nil." @@ -297,6 +320,96 @@ When called non-interactively with nil, syncs all calendars." (message "calendar-sync status:\n%s" (string-join (nreverse status-lines) "\n"))))) +;;; Batch entry point + +;; `emacs --batch' exits the moment its top-level form returns, and this +;; pipeline is asynchronous end to end -- curl in one process, the org +;; conversion in a second batch Emacs. So `calendar-sync-now' is the wrong +;; entry point for a timer: it returns as soon as the fetches are launched, +;; and batch Emacs would exit and kill both children mid-flight, having +;; written nothing and reported success. +;; +;; The batch path therefore starts the sync and then blocks on the same +;; per-calendar state the interactive session keeps. Nothing new tracks +;; completion -- the pipeline's own record of what finished is the signal. + +(defvar calendar-sync--batch-poll-seconds 0.2 + "Seconds `calendar-sync--batch-wait' blocks per iteration. +Short enough that the wait ends promptly once the last child exits, long +enough that the loop is not a spin. Rebound in tests.") + +(defvar calendar-sync-batch-timeout 300 + "Seconds `calendar-sync-batch-run' waits for every calendar to settle. +Covers a `calendar-sync-fetch-timeout' fetch plus the org conversion, with +room to spare: the calendars run in parallel, so this is not a per-calendar +budget.") + +(defun calendar-sync--batch-results (names) + "Return one (NAME . STATUS) pair per calendar in NAMES, in that order. +A calendar with no state entry reads `never' rather than nil, so one that +never started still counts when the failures are tallied." + (mapcar (lambda (name) + (cons name + (or (plist-get (calendar-sync--get-calendar-state name) :status) + 'never))) + names)) + +(defun calendar-sync--batch-failures (results) + "Return the rows of RESULTS that did not finish cleanly. +Only `ok' passes. `error' failed outright, `syncing' means the wait expired +with the fetch still in flight, and `never' means the sync never started -- +in all three the org file on disk is not the calendar's current contents, +which is the staleness the timer exists to prevent." + (seq-remove (lambda (row) (eq (cdr row) 'ok)) results)) + +(defun calendar-sync--batch-wait (names timeout) + "Block until no calendar in NAMES is syncing, or TIMEOUT seconds elapse. +Return non-nil when every calendar settled, nil when the timeout expired +first. `accept-process-output' is also what lets the fetch and conversion +sentinels run, so this loop drives the pipeline as well as waiting on it." + (let ((deadline (+ (float-time) timeout))) + (while (and (seq-some #'calendar-sync--syncing-p names) + (< (float-time) deadline)) + (accept-process-output nil calendar-sync--batch-poll-seconds)) + (not (seq-some #'calendar-sync--syncing-p names)))) + +;;;###autoload +(defun calendar-sync-batch-run (&optional timeout) + "Sync every configured calendar, blocking until all of them finish. +Return the (NAME . STATUS) rows. TIMEOUT defaults to +`calendar-sync-batch-timeout'. + +This is the entry point for the systemd timer. Prefer `calendar-sync-now' +in an interactive session, where returning immediately is the point." + (unless (calendar-sync--require-calendars) + (error "calendar-sync: no calendars configured")) + (let ((names (calendar-sync--calendar-names))) + (calendar-sync--sync-all-calendars) + (calendar-sync--batch-wait names (or timeout calendar-sync-batch-timeout)) + (calendar-sync--batch-results names))) + +;;;###autoload +(defun calendar-sync-batch-run-and-report () + "Run a batch sync, print one line per calendar, and return an exit code. +0 when every calendar synced, 1 otherwise. Written for +scripts/calendar-sync-run, which turns the code into the process's own exit +status so systemd records a failed sync instead of swallowing it. + +A failed row carries its recorded `:last-error'. The interactive failure +path logs the reason to *Messages', which batch Emacs discards at exit, so +without this the journal shows only `error' — no way to tell a cold +gpg-agent from a revoked feed token or a dead network without re-running the +sync by hand." + (let* ((results (calendar-sync-batch-run)) + (failures (calendar-sync--batch-failures results))) + (dolist (row results) + (let ((reason (unless (eq (cdr row) 'ok) + (plist-get (calendar-sync--get-calendar-state (car row)) + :last-error)))) + (princ (format "%s: %s%s\n" (car row) (cdr row) + (if reason (format " — %s" reason) ""))))) + (if failures 1 0))) + ;;; Timer management (defun calendar-sync--sync-timer-function () @@ -405,6 +518,11 @@ Syncs all calendars immediately, then every `calendar-sync-interval-minutes'." ;; Defer auto-sync until calendar data is first needed. ;; +;; Dormant unless `calendar-sync-auto-start' is turned back on -- the systemd +;; timer owns the schedule now. Kept because the reasoning below still holds +;; for anyone who hands the schedule back to the editor, and because it is the +;; only safe shape for an in-editor start. +;; ;; The :secret-host feed URLs live in authinfo.gpg, and BOTH the immediate sync ;; and every periodic timer tick resolve them. Calling `calendar-sync-start' at ;; load (immediate sync + recurring timer) therefore decrypts authinfo.gpg right @@ -412,6 +530,11 @@ Syncs all calendars immediately, then every `calendar-sync-interval-minutes'." ;; after a reboot). Defer the whole start to the first org-agenda use, so the ;; unlock happens when the user actually asks for calendar data. A manual ;; `calendar-sync-start' / `calendar-sync-now' still works on demand. +;; +;; That deferral is also what made the timer necessary: hanging the start on +;; `org-agenda-mode-hook' means a session where the agenda is never opened +;; never syncs at all, which after a reboot is every session until the first +;; agenda call. The batch path has no such trigger to miss. (defun calendar-sync--auto-start-on-first-agenda () "Start auto-sync on the first org-agenda use, then remove this hook. One-shot: deferring `calendar-sync-start' until the agenda is first built keeps a diff --git a/modules/config-utilities.el b/modules/config-utilities.el index 4332f407..62fc29d0 100644 --- a/modules/config-utilities.el +++ b/modules/config-utilities.el @@ -196,27 +196,27 @@ Returns the count of files deleted." count user-emacs-directory))) (keymap-set cj/debug-config-keymap "c d" 'cj/delete-emacs-home-compiled-files) -(defun cj/compile-this-elisp-buffer () - "Compile the current .el: prefer native (.eln), else .elc. Message if neither." - (interactive) - (unless (and buffer-file-name (string-match-p "\\.el\\'" buffer-file-name)) - (user-error "Not visiting a .el file")) - (save-buffer) - (let ((file buffer-file-name)) +(defun cj/--compile-elisp-file (file &optional available-p) + "Compile FILE: prefer async native, then sync native, then byte-compile. +AVAILABLE-P decides which compilers exist; it defaults to `fboundp'. It is +a parameter so tests can force each branch without redefining `fboundp': +an `fset' on that subr pulls in comp-run and bytecomp, whose own `defun' +of `byte-compile-file' then lands on top of any test double." + (let ((available-p (or available-p #'fboundp))) (cond ;; Native compilation (async preferred) - ((fboundp 'native-compile-async) + ((funcall available-p 'native-compile-async) (native-compile-async file) (message "Queued native compilation for %s" file)) ;; Native compilation (sync, if async not available) - ((fboundp 'native-compile) + ((funcall available-p 'native-compile) (condition-case err (progn (native-compile file) (message "Native-compiled %s" file)) (error (message "Native compile failed: %s" (error-message-string err))))) ;; Byte-compile fallback - ((fboundp 'byte-compile-file) + ((funcall available-p 'byte-compile-file) (let ((out (byte-compile-file file))) (if out (message "Byte-compiled -> %s" out) @@ -224,6 +224,14 @@ Returns the count of files deleted." ;; Neither facility available (t (message "No compilation available (no native-compile, no byte-compile)"))))) + +(defun cj/compile-this-elisp-buffer () + "Compile the current .el: prefer native (.eln), else .elc. Message if neither." + (interactive) + (unless (and buffer-file-name (string-match-p "\\.el\\'" buffer-file-name)) + (user-error "Not visiting a .el file")) + (save-buffer) + (cj/--compile-elisp-file buffer-file-name)) (keymap-set cj/debug-config-keymap "c ." 'cj/compile-this-elisp-buffer) ;; --------------------------- Information Reporting --------------------------- diff --git a/modules/custom-buffer-file.el b/modules/custom-buffer-file.el index 0ca06cf9..fdcc4d2f 100644 --- a/modules/custom-buffer-file.el +++ b/modules/custom-buffer-file.el @@ -59,7 +59,7 @@ (declare-function mm-insert-part "mm-decode") (declare-function mm-destroy-parts "mm-decode") (require 'external-open) ;; for cj/xdg-open, cj/open-this-file-with -(require 'system-lib) ;; cj/confirm-strong (overwrite confirms), used below +(require 'system-lib) ;; cj/confirm-destructive (overwrite confirms), used below ;; cj/kill-buffer-and-window and cj/kill-other-window-buffer defined in undead-buffers.el (declare-function cj/kill-buffer-and-window "undead-buffers") @@ -168,7 +168,7 @@ When called interactively, prompts for confirmation if target file exists." (condition-case _ (cj/--move-buffer-and-file dir nil) (file-already-exists - (if (cj/confirm-strong (format "File %s exists; overwrite? " target)) + (if (cj/confirm-destructive (format "File %s exists; overwrite? " target)) (cj/--move-buffer-and-file dir t) (message "File not moved")))))) @@ -208,7 +208,7 @@ When called interactively, prompts for confirmation if target file exists." (condition-case err (cj/--rename-buffer-and-file new-name nil) (file-already-exists - (if (cj/confirm-strong (format "File %s exists; overwrite? " new-name)) + (if (cj/confirm-destructive (format "File %s exists; overwrite? " new-name)) (cj/--rename-buffer-and-file new-name t) (message "File not renamed"))) (error diff --git a/modules/dirvish-config.el b/modules/dirvish-config.el index edbb0b35..6c849198 100644 --- a/modules/dirvish-config.el +++ b/modules/dirvish-config.el @@ -590,6 +590,7 @@ no popup frame is live." ("ps" ,(concat pix-dir "/screenshots/") "pictures screenshots") ("px" ,pix-dir "pictures directory") ("wp" ,(concat pix-dir "/wallpaper/") "pictures wallpaper") + ("wv" ,(concat videos-dir "wallpaper/") "wallpaper videos") ("fp" "/ftp:android@192.168.86.13#2221:/" "phone ftp (android)") ("rcj" "/sshx:cjennings@cjennings.net:~" "remote c@cjennings.net") ("rtl" "/sshx:cjennings@truenas.local:~" "remote cjennings@truenas.local") diff --git a/modules/dwim-shell-config.el b/modules/dwim-shell-config.el index 54272fd5..12908f51 100644 --- a/modules/dwim-shell-config.el +++ b/modules/dwim-shell-config.el @@ -22,7 +22,7 @@ ;;; Code: (require 'cl-lib) -(require 'system-lib) ;; cj/confirm-strong (permanent file destruction confirm) +(require 'system-lib) ;; cj/confirm-destructive (permanent file destruction confirm) (require 'external-open) ;; cj/xdg-open, called to open conversion output files ;; Function declarations (lazily-loaded packages and sibling modules). @@ -765,7 +765,7 @@ switching off the .7z format to gpg-wrapped tar." Uses =shred -u= so the file is unlinked after overwriting, matching the \"delete\" the command name and prompt promise." (interactive) - (when (cj/confirm-strong "This will permanently destroy files. Continue? ") + (when (cj/confirm-destructive "This will permanently destroy files. Continue? ") (dwim-shell-command-on-marked-files "Secure delete" "shred -vfzu -n 3 '<<f>>'" diff --git a/modules/eat-config.el b/modules/eat-config.el index 01d0fbe6..f764848e 100644 --- a/modules/eat-config.el +++ b/modules/eat-config.el @@ -415,7 +415,8 @@ terminal. ai-term's agent buffers are managed separately via M-SPC." ;; Carried over from the ghostel era for the EAT agent terminals (ai-term). ;; Agents run EAT over tmux, so copy-mode is tmux's own copy-mode -- the same UX ;; ghostel-over-tmux had. C-<up> enters it and scrolls up in one stroke; C-; x c -;; enters it via the menu, and C-; x h grabs the whole pane history into a buffer. +;; enters it via the menu, C-; x h grabs the whole pane history into a buffer, +;; and C-; x d detaches the tmux client without going through its prefix. (declare-function cj/register-prefix-map "keybindings") (declare-function eat-emacs-mode "eat") @@ -585,6 +586,20 @@ scrollback) and moves point to the start of the line." (eat-emacs-mode) (beginning-of-line))) +(defun cj/term-tmux-detach () + "Detach the tmux client from inside an agent terminal. +Writes tmux's prefix and the detach key (C-b d) straight into the pty, the +same path `cj/term-copy-mode-dwim' uses for C-b [. A keyboard C-b inside +the Claude Code pane has been observed to land as stray text instead of +reaching tmux as a prefix (root cause not yet pinned down), so the string +path is the reliable one. Outside tmux it writes +nothing and says so, since C-b d typed into a plain shell is just a control +character." + (interactive) + (if (cj/term--in-tmux-p) + (cj/--term-send-string "\C-bd") + (message "cj/term-tmux-detach: not attached to tmux"))) + (defun cj/term--tmux-pane-in-copy-mode-p (pane-id) "Return non-nil when tmux PANE-ID is currently displaying a mode. tmux's `pane_in_mode' is 1 while a pane is in any mode; copy-mode is the only @@ -613,13 +628,15 @@ pty; without tmux, moves point up in EAT's emacs-mode buffer." (cj/term-copy-mode-dwim)) (forward-line -1))))) -;; The C-; x terminal prefix (copy-mode, tmux history, the F12 toggle). C-<up> +;; The C-; x terminal prefix (copy-mode, tmux detach, tmux history, the F12 +;; toggle). C-<up> ;; enters copy-mode + scrolls in one stroke; bound in EAT's semi-char map so it ;; reaches Emacs from inside an agent terminal. (defvar-keymap cj/term-map :doc "Personal terminal command map.") (cj/register-prefix-map "x" cj/term-map) (keymap-set cj/term-map "c" #'cj/term-copy-mode-dwim) +(keymap-set cj/term-map "d" #'cj/term-tmux-detach) (keymap-set cj/term-map "h" #'cj/term-tmux-history) (keymap-set cj/term-map "t" #'cj/term-toggle) diff --git a/modules/google-keep-config.el b/modules/google-keep-config.el index 1738fa6e..c0a5374f 100644 --- a/modules/google-keep-config.el +++ b/modules/google-keep-config.el @@ -46,6 +46,27 @@ Unset until the one-time setup is done; `cj/keep-refresh' warns when nil." :type 'string :group 'cj/keep) +(defcustom cj/keep-local-config-file + (expand-file-name "google-keep.local.el" user-emacs-directory) + "Machine-local Keep config loaded when readable. +The intended place for `cj/keep-python' (a machine-local venv path) and +`cj/keep-email' -- gitignored, same shape as calendar-sync.local.el." + :type 'file + :group 'cj/keep) + +(defun cj/keep--load-local-config () + "Load the machine-local Keep config when available. +Return non-nil when the file loaded cleanly, nil when it is absent or +broken; a broken file is reported via `message', never signaled." + (when (file-readable-p cj/keep-local-config-file) + (condition-case err + (load cj/keep-local-config-file nil t) + (error + (message "google-keep: Failed to load local config %s: %s" + (abbreviate-file-name cj/keep-local-config-file) + (error-message-string err)) + nil)))) + (defvar cj/keep--bridge-script (expand-file-name "scripts/google-keep/keep-bridge.py" user-emacs-directory) "Path to the gkeepapi bridge script.") @@ -202,6 +223,10 @@ Returns the note count." (keymap-global-set "C-c k" cj/keep-prefix-map) +;; Machine-local settings (venv interpreter, email) load before the +;; interpreter warning below, so a venv path set locally is what gets checked. +(cj/keep--load-local-config) + ;; Warn at load if the interpreter is missing; gkeepapi/token failures surface ;; at refresh time via the bridge's stderr reason token. (cj/executable-find-or-warn cj/keep-python "Google Keep bridge" 'google-keep-config) diff --git a/modules/music-config.el b/modules/music-config.el index 233bae72..47863e41 100644 --- a/modules/music-config.el +++ b/modules/music-config.el @@ -31,7 +31,7 @@ (require 'user-constants) (require 'keybindings) ;; provides cj/custom-keymap (require 'cj-window-toggle-lib) ;; side-window size memory (F10 toggle) -(require 'system-lib) ;; cj/confirm-strong (overwrite confirms) +(require 'system-lib) ;; cj/confirm-destructive (overwrite confirms) ;; Declare these foreign package vars special so `let'-binding them below ;; compiles as a dynamic bind, not a dead lexical local -- otherwise emms / @@ -677,18 +677,39 @@ M3U-FILE should be an existing, writable M3U file path." (unless (file-writable-p m3u-file) (error "M3U file is not writable: %s" m3u-file)) - ;; Convert absolute path to relative path from music root - (let ((relative-path (if (file-name-absolute-p track-path) - (file-relative-name track-path cj/music-root) - track-path))) - ;; Determine if we need a leading newline - (let ((needs-prefix-newline nil) - (file-size (file-attribute-size (file-attributes m3u-file)))) - (when (> file-size 0) - ;; Read the last character of the file to check if it ends with newline - (with-temp-buffer - (insert-file-contents m3u-file nil (max 0 (1- file-size)) file-size) - (setq needs-prefix-newline (not (= (char-after (point-min)) ?\n))))) + ;; Relative when the track sits under the playlist's own directory, absolute + ;; otherwise. + ;; + ;; The base is the playlist rather than `cj/music-root' because that is what + ;; both readers resolve against -- `cj/music--m3u-file-tracks' and EMMS's + ;; `emms-source-playlist-parse-m3u'. Inside the music root the two are the + ;; same directory, which is why basing on the root went unnoticed: it only + ;; wrote an unresolvable line once a playlist lived somewhere else. + ;; + ;; Falling back to absolute keeps a cross-tree reference readable, and it + ;; survives the playlist being moved again. A playlist in the mpd directory + ;; pointing into ~/music would otherwise carry a four-level ../ chain that + ;; breaks the moment anything moves. + (let* ((dir (file-name-directory m3u-file)) + (relative-path + (if (not (file-name-absolute-p track-path)) + track-path + (let ((rel (file-relative-name track-path dir))) + (if (string-prefix-p "../" rel) track-path rel))))) + ;; Does the file need a separating newline first? Read the content and look + ;; at its last character, rather than seeking to a byte offset derived from + ;; `file-attributes'. That call does not follow symlinks, so on a + ;; stow-deployed playlist it measures the link string instead of the file: + ;; every symlinked playlist read the wrong byte and gained a blank line per + ;; append, and where the link string was the longer of the two the range fell + ;; outside the file entirely and the append died on a nil `char-after'. + ;; Playlists are small text files, so reading one is cheaper than being + ;; clever about offsets. + (let ((needs-prefix-newline + (with-temp-buffer + (insert-file-contents m3u-file) + (and (> (buffer-size) 0) + (/= (char-before (point-max)) ?\n))))) ;; Append the track with proper newline handling (with-temp-buffer @@ -833,7 +854,7 @@ reloaded playlist keeps its display name and cover art." (when (string-empty-p (string-trim chosen)) (user-error "Playlist name cannot be empty")) (when (and (file-exists-p full) - (not (cj/confirm-strong (format "Overwrite %s? " filename)))) + (not (cj/confirm-destructive (format "Overwrite %s? " filename)))) (user-error "Aborted saving playlist")) (make-directory dir t) (cj/music--write-playlist-file full tracks entries) @@ -875,7 +896,7 @@ clears its file association." (let ((file (cj/music--select-m3u-file "Delete playlist: "))) (if (not file) (message "Playlist deletion cancelled") - (unless (cj/confirm-strong (format "Delete playlist %s? " + (unless (cj/confirm-destructive (format "Delete playlist %s? " (file-name-nondirectory file))) (user-error "Aborted deleting playlist")) (cj/music--delete-playlist-file file) diff --git a/modules/org-agenda-config.el b/modules/org-agenda-config.el index 1e91fa48..20714d5d 100644 --- a/modules/org-agenda-config.el +++ b/modules/org-agenda-config.el @@ -20,21 +20,25 @@ ;; keep normal agenda opens fast. ;;; Code: +(require 'seq) (require 'user-constants) (require 'system-lib) (require 'cj-cache-lib) -(defcustom cj/org-agenda-window-height 0.75 - "Fraction of the selected frame used for the org agenda window." - :type 'number - :group 'org-agenda) - (defun cj/--org-agenda-display-rule () - "Return the display-buffer rule for the org agenda buffer." - `("\\*Org Agenda\\*" - (display-buffer-reuse-mode-window display-buffer-below-selected) - (dedicated . t) - (window-height . ,cj/org-agenda-window-height))) + "Return the display-buffer rule for the org agenda buffer. +`display-buffer-full-frame' gives the agenda the whole frame rather than a +fraction of it, so the view is a surface you read rather than a strip you +squint at. `org-agenda-restore-windows-after-quit' (set below) is what +makes that non-destructive: quitting the agenda puts the previous window +layout back. + +The window is deliberately not `dedicated': with the agenda owning the only +window, a dedicated one leaves `org-agenda-switch-to' (RET on an item) with +nowhere to put the file, and it splits or opens a frame instead of simply +replacing the agenda." + '("\\*Org Agenda\\*" + (display-buffer-reuse-mode-window display-buffer-full-frame))) ;; Load debug functions if enabled (when (or (eq cj/debug-modules t) @@ -65,7 +69,12 @@ ;; that reaches `org-agenda-files' another way. (setq org-agenda-skip-unavailable-files t) - ;; display the agenda from the bottom + ;; The agenda takes the whole frame, so quitting it has to give the previous + ;; window layout back -- otherwise every F8 costs the arrangement of windows + ;; that were up when it was pressed. + (setq org-agenda-restore-windows-after-quit t) + + ;; display the agenda across the whole frame (add-to-list 'display-buffer-alist (cj/--org-agenda-display-rule)) @@ -75,6 +84,89 @@ (local-set-key (kbd "s-<left>") #'org-agenda-todo-previousset)))) +;; ---------------------------- Agenda Auto-Refresh ---------------------------- +;; A full-frame agenda is meant to be left up and glanced at, so it has to stay +;; current on its own: the now-line moves, and calendar-sync writes new events +;; into the agenda files behind it. One repeating timer rebuilds whichever +;; agenda is actually on screen. + +(defcustom cj/org-agenda-refresh-seconds 300 + "Cadence, in seconds, of the org-agenda auto-refresh. +The timer fires on wall-clock multiples of this value, so the default 300 +refreshes on the :00/:05/:10 marks rather than five minutes after whenever +the agenda happened to open." + :type 'integer + :group 'org-agenda) + +(defvar cj/--org-agenda-refresh-timer nil + "The repeating auto-refresh timer, or nil when auto-refresh is stopped.") + +(declare-function org-agenda-redo "org-agenda" (&optional all)) + +(defun cj/--org-agenda-seconds-to-next-mark (time period) + "Return seconds from TIME to the next wall-clock multiple of PERIOD. +TIME is any Emacs time value; PERIOD is a positive number of seconds, so +300 gives the :00/:05 marks. A TIME landing exactly on a mark returns a +full PERIOD rather than zero, so the timer never fires twice back to back." + (unless (and (numberp period) (> period 0)) + (error "Refresh period must be a positive number of seconds: %S" period)) + (let ((remainder (mod (floor (float-time time)) period))) + (if (zerop remainder) period (- period remainder)))) + +(defun cj/--org-agenda-refresh-window () + "Return a live window displaying an org-agenda buffer, or nil. +Only a visible agenda is worth rebuilding: an off-screen one costs the same +full rescan and shows it to nobody, and it will be rebuilt on the next tick +after it comes back into view." + (seq-find (lambda (window) + (with-current-buffer (window-buffer window) + (derived-mode-p 'org-agenda-mode))) + (window-list-1 nil 'nomini 'visible))) + +(defun cj/--org-agenda-auto-refresh () + "Rebuild the on-screen agenda, leaving point on the line it was on. +Does nothing when no agenda is displayed. + +The body is wrapped in `condition-case' deliberately. This runs from a +repeating timer, where an unguarded signal resignals on every tick and +buries Emacs in identical backtraces -- the failure mode that made +calendar-sync's hourly timer unusable. A failed rebuild is logged and the +timer keeps its cadence." + (condition-case err + (when-let* ((window (cj/--org-agenda-refresh-window))) + (with-selected-window window + (let ((line (line-number-at-pos))) + (org-agenda-redo) + (goto-char (point-min)) + (forward-line (1- line))))) + (error + (cj/log-silently + (format "org-agenda auto-refresh failed: %s" (error-message-string err)))))) + +(defun cj/org-agenda-auto-refresh-start () + "Start the wall-clock-aligned agenda auto-refresh timer. +Cancels any existing timer first, so re-loading this module into a running +daemon replaces the ticker rather than stacking a second one." + (interactive) + (cj/org-agenda-auto-refresh-stop) + (setq cj/--org-agenda-refresh-timer + (run-at-time (cj/--org-agenda-seconds-to-next-mark + (current-time) cj/org-agenda-refresh-seconds) + cj/org-agenda-refresh-seconds + #'cj/--org-agenda-auto-refresh))) + +(defun cj/org-agenda-auto-refresh-stop () + "Cancel the agenda auto-refresh timer. A no-op when already stopped." + (interactive) + (when (timerp cj/--org-agenda-refresh-timer) + (cancel-timer cj/--org-agenda-refresh-timer)) + (setq cj/--org-agenda-refresh-timer nil)) + +;; Arm at load. Skipped under `noninteractive' so a batch test run doesn't +;; carry a live repeating timer it has nothing to refresh. +(unless noninteractive + (cj/org-agenda-auto-refresh-start)) + ;; ----------------------- Project-name Category Override --------------------- ;; The default `org-category' for a todo.org buffer is "todo" (the filename ;; without extension), which renders as "todo:" in every agenda `%c' column @@ -107,17 +199,27 @@ nil so the org default category applies." (defun cj/--org-set-todo-category () "Set buffer-local `org-category' to the project name for a todo.org buffer. -Runs from `org-mode-hook'. Only overrides when `org-category' is still -the default-from-filename (\"todo\"), so an explicit `#+CATEGORY:' in -the file keeps precedence." +Runs from `org-mode-hook'. Only overrides when nothing has set +`org-category', so an explicit `#+CATEGORY:' in the file keeps precedence. + +The nil test is the whole guard, and it took a while to get right. Org does +not assign the filename fallback to `org-category': with no `#+CATEGORY:' the +variable stays nil and `org-get-category' derives \"todo\" at read time. An +earlier version guarded on `(string= \"todo\" org-category)', which is a state +org never produces, so this hook did nothing from the day it shipped." (when (and buffer-file-name (boundp 'org-category) - (stringp org-category) - (string= "todo" org-category)) + (null org-category)) (when-let* ((project (cj/--org-todo-category-from-file buffer-file-name))) (setq-local org-category project)))) -(add-hook 'org-mode-hook #'cj/--org-set-todo-category) +;; Depth -100 so this runs FIRST, and it is load-bearing. `org-get-category' +;; resolves a deferred `:CATEGORY' that the org-element cache then holds, so any +;; hook that reads the category before this one freezes "todo" in that cache and +;; leaves the `setq-local' below inert -- `org-category' reads correct while the +;; agenda still shows "todo". `add-hook' prepends by default, so without the +;; depth every hook added later would run earlier, and three already do. +(add-hook 'org-mode-hook #'cj/--org-set-todo-category -100) ;; ------------------------ Org Agenda File List Cache ------------------------- ;; Cache agenda file list to avoid expensive directory scanning on every view. @@ -225,14 +327,11 @@ improves performance from several seconds to instant." Use this after adding new projects or todo.org files. Bypasses cache and scans directories from scratch. -Bound to C-M-<f8>, the force-rebuild sibling of the F8 agenda family -\(<f8> display, s-<f8> all files, C-<f8> single project, M-<f8> this buffer). -The binding lives in `org-agenda-frame.el', which took S-<f8> for the -agenda-frame toggle and moved the force-rescan here." +Bound to S-<f8>, the force-rebuild sibling of the F8 agenda family +\(<f8> display, s-<f8> all files, C-<f8> single project, M-<f8> this buffer)." (interactive) (cj/build-org-agenda-list 'force-rebuild)) -;; S-<f8> and C-M-<f8> are bound by `org-agenda-frame.el' (cj/--agenda-frame-install-keys): -;; S-<f8> toggles the dedicated agenda frame; C-M-<f8> runs the force-rescan above. +(global-set-key (kbd "S-<f8>") #'cj/org-agenda-refresh-files) (defun cj/todo-list-all-agenda-files () "Displays an \\='org-agenda\\=' todo list. diff --git a/modules/org-agenda-frame.el b/modules/org-agenda-frame.el deleted file mode 100644 index f0de99ce..00000000 --- a/modules/org-agenda-frame.el +++ /dev/null @@ -1,847 +0,0 @@ -;;; org-agenda-frame.el --- Dedicated agenda frame -*- lexical-binding: t; -*- -;; author: Craig Jennings <c@cjennings.net> - -;;; Commentary: -;; -;; Layer: 4 (Optional). -;; Category: O/D. -;; Load shape: eager (binds keys in Phase 2; Phase 1 defines helpers only). -;; Top-level side effects: none yet (Phase 1 is private helpers). -;; Runtime requires: none. -;; Direct test load: yes. -;; -;; A dedicated Emacs frame of the running daemon that shows a today-anchored -;; seven-day org-agenda, refreshing itself, kept read-only and focus-locked. -;; A normal (non-fullscreen) frame, so a tiling WM places it side by side with -;; the working frame. Spawned/raised/closed by one key. See the spec: -;; docs/specs/2026-07-17-org-agenda-fullscreen-frame-spec.org. -;; -;; Phase 1 (this pass) builds non-interactive helpers only: frame lookup, -;; spawn/raise/delete, the dedicated view, the default-deny read-only policy, -;; and working-frame routing. No interactive command or key is bound until -;; Phase 2, so nothing user-visible changes yet. - -;;; Code: - -(require 'seq) - -;; Declared, not required: `org-agenda-config' pulls in vc packages that don't -;; load under `make test' (no package-initialize). The frame module references -;; org-agenda symbols through these declarations and does its real wiring inside -;; `with-eval-after-load' so a batch test-load runs no org-agenda side effects. -(defvar org-agenda-custom-commands) -(defvar org-agenda-finalize-hook) -(defvar org-agenda-mode-map) -(defvar org-agenda-sticky) -(defvar org-agenda-window-setup) -(declare-function cj/build-org-agenda-list "org-agenda-config" (&optional force-rebuild)) -(declare-function cj/org-agenda-refresh-files "org-agenda-config" ()) -(declare-function org-agenda-redo "org-agenda" (&optional all)) -(declare-function org-agenda-next-line "org-agenda" ()) -(declare-function org-agenda-previous-line "org-agenda" ()) -(declare-function org-agenda-next-item "org-agenda" (n)) -(declare-function org-agenda-previous-item "org-agenda" (n)) -(declare-function org-agenda-open-link "org-agenda" (&optional arg)) -(declare-function org-get-at-bol "org" (property)) -(declare-function org-fold-show-context "org-fold" (&optional key)) -(declare-function org-agenda "org-agenda" (&optional arg org-keys restriction)) -;; No declare-function for -safe-redo / -delete: they are defined later in THIS -;; file, and the byte-compiler resolves same-file forward references at end of -;; compilation. A declare-function for a same-file function instead counts as a -;; second definition ("defined multiple times") and, worse, its declared arglist -;; overrides the real one for arg-count checking -- the empty () shadowed -;; -safe-redo's actual (&optional frame), disabling that check. - -(defconst cj/--agenda-frame-parameter 'cj/agenda-frame - "Frame parameter marking the dedicated agenda frame. -Its presence (non-nil) is how `cj/--agenda-frame' locates the frame among -all of the daemon's frames.") - -(defvar cj/--agenda-frame-launch-frame nil - "The frame selected when the agenda frame was last spawned. -Preferred routing target for source files opened from the agenda (see -`cj/--agenda-frame-working-frame'); ignored once it is dead or is itself -the agenda frame.") - -(defun cj/--agenda-frame-p (frame) - "Return non-nil when FRAME is a live agenda frame. -FRAME is an agenda frame when it is live and carries the -`cj/--agenda-frame-parameter' marker; a dead frame is never one." - (and (frame-live-p frame) - (frame-parameter frame cj/--agenda-frame-parameter))) - -(defun cj/--agenda-frame () - "Return the live agenda frame, or nil. -The frame is identified by the `cj/--agenda-frame-parameter' marker; a -dead frame is never returned even if it still carries the marker." - (seq-find #'cj/--agenda-frame-p (frame-list))) - -(defun cj/--agenda-frame-working-frame () - "Return a live non-agenda frame to route source files into, or nil. -Prefer `cj/--agenda-frame-launch-frame' when it is still live and not the -agenda frame; otherwise the first live non-agenda frame among all frames. -Return nil when the agenda frame is the only live frame -- the caller then -creates a normal frame." - (or (and (frame-live-p cj/--agenda-frame-launch-frame) - (not (cj/--agenda-frame-p cj/--agenda-frame-launch-frame)) - cj/--agenda-frame-launch-frame) - (seq-find (lambda (frame) - (and (frame-live-p frame) - (not (cj/--agenda-frame-p frame)))) - (frame-list)))) - -;;; The dedicated seven-day view (org-agenda-custom-commands key F) - -(defconst cj/--agenda-frame-command-key "F" - "The `org-agenda-custom-commands' key for the agenda-frame view. -The existing top-level key is `d' (org-agenda-config.el:344), so `F' is -collision-free. The sticky buffer derives its name from this key -\(*Org Agenda(F)*).") - -(defvar cj/--agenda-frame-span 7 - "Span, in days, of the agenda-frame view. -The `F' custom command reads this via its `org-agenda-span' setting, which -Org evaluates on every build and every redo, so `cj/--agenda-frame-day-view' -\(span 1) and `cj/--agenda-frame-week-view' (span 7) change it and the next -redo picks up the new span. Reset to 7 on each spawn so a fresh frame opens -at the documented default.") - -(defun cj/--agenda-frame-command () - "Return the `org-agenda-custom-commands' entry for the agenda frame. -A one-block agenda: a `cj/--agenda-frame-span'-day span anchored to today -rather than -Monday (`org-agenda-list' otherwise anchors any seven-day span to the -week start in Org 9.7.11), rendered in the frame's sole window -\(`current-window', so Org's default `reorganize-frame' can't split it), -as its own sticky *Org Agenda(F)* buffer, with follow-mode forced off so -a non-nil global default can't open a second window at build time." - `(,cj/--agenda-frame-command-key "Agenda frame: 7-day today-anchored" - ((agenda "" - ((org-agenda-span cj/--agenda-frame-span) - (org-agenda-start-day "0d") - (org-agenda-start-on-weekday nil) - (org-agenda-start-with-follow-mode nil) - ;; Narrow category column: the global agenda format pads the - ;; category to 25 chars, leaving a wide blank gutter between - ;; the source name (todo:, dcal:) and the item. - (org-agenda-prefix-format " %i %-10:c%?-12t% s")))) - ;; No `org-agenda-sticky' here, deliberately: these settings are baked - ;; into the buffer's series-redo-cmd and re-applied by every redo, and a - ;; sticky t mid-redo makes `org-agenda-use-sticky-p' true while the - ;; buffer exists -- `org-agenda-prepare' then throws \\='exit ("use `r' - ;; to refresh") with no catch, failing every refresh tick. Stickiness - ;; is bound in the spawn wrapper instead, where it names the buffer. - ((org-agenda-window-setup 'current-window)))) - -(defun cj/--agenda-frame-register-command () - "Register the agenda-frame view in `org-agenda-custom-commands'. -Idempotent: any existing entry for `cj/--agenda-frame-command-key' is -replaced, so a module reload never accumulates duplicate keys." - (setq org-agenda-custom-commands - (cons (cj/--agenda-frame-command) - (assoc-delete-all cj/--agenda-frame-command-key - org-agenda-custom-commands)))) - -;;; Engage routing — open the item's source outside the agenda frame - -(defun cj/--agenda-frame-item-marker () - "Return the source marker for the agenda item at point, or nil. -Prefers the item's own marker, falling back to the heading marker. Reads -the text property directly (like `org-get-at-bol') so point restoration -is exercisable without loading org." - (or (get-text-property (line-beginning-position) 'org-marker) - (get-text-property (line-beginning-position) 'org-hd-marker))) - -(defun cj/--agenda-frame-target-frame () - "Return the frame to open agenda source in, creating one when needed. -The engage action never opens into the agenda frame: it targets the -working frame (`cj/--agenda-frame-working-frame'), and when the agenda -frame is the only live frame it creates a normal, non-fullscreen frame." - (or (cj/--agenda-frame-working-frame) - (make-frame))) - -(defun cj/--agenda-frame-engage-open () - "Open the source of the agenda item at point in the working frame. -Routes to the MRU non-agenda frame (or a new normal frame when the agenda -frame is the only one), so the agenda frame keeps showing the agenda. -Signals a `user-error' when point is not on an agenda item." - (interactive) - (let ((marker (cj/--agenda-frame-item-marker))) - (unless (and marker (marker-buffer marker)) - (user-error "No agenda item on this line")) - (let ((buffer (marker-buffer marker)) - (pos (marker-position marker)) - (frame (cj/--agenda-frame-target-frame))) - (select-frame-set-input-focus frame) - (pop-to-buffer-same-window buffer) - (widen) - (goto-char pos) - (when (derived-mode-p 'org-mode) - (org-fold-show-context 'agenda)) - (beginning-of-line)))) - -(defun cj/--agenda-frame-engage-mouse (event) - "Open the agenda item clicked by EVENT in the working frame." - (interactive "e") - (mouse-set-point event) - (cj/--agenda-frame-engage-open)) - -(defun cj/--agenda-frame-open-link () - "Follow the link in the agenda item at point, in the working frame." - (interactive) - (select-frame-set-input-focus (cj/--agenda-frame-target-frame)) - (org-agenda-open-link)) - -(defun cj/--agenda-frame-close () - "Close the agenda frame from within it. -Bound to q, Q, and x so Org's own quit keys delete the whole frame -\(and cancel its timer) rather than leaving a sole-window agenda -frame stranded on a non-agenda buffer." - (interactive) - (cj/--agenda-frame-delete)) - -;;; Default-deny read-only policy - -(defconst cj/--agenda-frame-readonly-message - "Agenda frame is read-only — press RET to edit in your working frame" - "Shown when a mutating or buffer-opening command is denied in the frame.") - -(defconst cj/--agenda-frame-fixed-view-message - "Agenda frame shows only the day (d) and week (w) views" - "Shown when a view-changing command is denied in the frame.") - -(defun cj/--agenda-frame-denied-readonly () - "Deny a mutating or buffer-opening command in the agenda frame. -The default binding for every key not on the allowlist." - (interactive) - (message "%s" cj/--agenda-frame-readonly-message)) - -(defun cj/--agenda-frame-denied-fixed-view () - "Deny a view-changing command that would break the today-anchored span." - (interactive) - (message "%s" cj/--agenda-frame-fixed-view-message)) - -(defvar cj/agenda-frame-mode-map - (let ((map (make-sparse-keymap))) - ;; Default-deny: every key/mouse event not rebound below funnels through - ;; this one catch-all, so mutations (present and future) are read-only. - (define-key map [t] #'cj/--agenda-frame-denied-readonly) - ;; Hide the Org Agenda menu-bar entry so there is no menu path to a mutation. - (define-key map [menu-bar org-agenda] #'undefined) - ;; (a) Navigation — allowlisted to their org-agenda commands. - (define-key map (kbd "n") #'org-agenda-next-line) - (define-key map (kbd "p") #'org-agenda-previous-line) - (define-key map (kbd "<down>") #'org-agenda-next-line) - (define-key map (kbd "<up>") #'org-agenda-previous-line) - (define-key map (kbd "C-n") #'org-agenda-next-line) - (define-key map (kbd "C-p") #'org-agenda-previous-line) - (define-key map (kbd "N") #'org-agenda-next-item) - (define-key map (kbd "P") #'org-agenda-previous-item) - (define-key map (kbd "C-v") #'scroll-up-command) - (define-key map (kbd "M-v") #'scroll-down-command) - (define-key map (kbd "M-<") #'beginning-of-buffer) - (define-key map (kbd "M->") #'end-of-buffer) - ;; Read-only point motion and search within the agenda. - (define-key map (kbd "C-a") #'move-beginning-of-line) - (define-key map (kbd "C-e") #'move-end-of-line) - (define-key map (kbd "C-f") #'forward-char) - (define-key map (kbd "C-b") #'backward-char) - (define-key map (kbd "C-s") #'isearch-forward) - (define-key map (kbd "C-r") #'isearch-backward) - (define-key map (kbd "C-g") #'keyboard-quit) - ;; (b) Engage / open — routed to the working frame, never the agenda frame. - ;; Bind the GUI function-key events ([return]/[tab]) as well as the ASCII - ;; forms: the [t] catch-all otherwise gives `return'/`tab' a binding, which - ;; suppresses their function-key translation to RET/TAB, so a bare RET would - ;; hit the deny handler instead of engaging in a graphical frame. - (define-key map (kbd "RET") #'cj/--agenda-frame-engage-open) - (define-key map (kbd "TAB") #'cj/--agenda-frame-engage-open) - (define-key map [return] #'cj/--agenda-frame-engage-open) - (define-key map [tab] #'cj/--agenda-frame-engage-open) - (define-key map (kbd "<mouse-2>") #'cj/--agenda-frame-engage-mouse) - (define-key map (kbd "C-c C-o") #'cj/--agenda-frame-open-link) - ;; (c) The frame's own controls. - (define-key map (kbd "q") #'cj/--agenda-frame-close) - (define-key map (kbd "Q") #'cj/--agenda-frame-close) - (define-key map (kbd "x") #'cj/--agenda-frame-close) - (define-key map (kbd "r") #'cj/--agenda-frame-safe-redo) - ;; g is the muscle-memory agenda refresh; keep it working here (the - ;; frame-scoped safe redo, same as r) rather than denying it as a - ;; view-change. C-M-<f8> stays the force-rescan. - (define-key map (kbd "g") #'cj/--agenda-frame-safe-redo) - ;; d / w toggle the span (today's day vs the seven-day view) in place; the - ;; other view-changers stay denied to keep the today-anchored frame stable. - (define-key map (kbd "d") #'cj/--agenda-frame-day-view) - (define-key map (kbd "w") #'cj/--agenda-frame-week-view) - (define-key map (kbd "S-<f8>") #'cj/agenda-frame-toggle) - (define-key map (kbd "C-M-<f8>") #'cj/org-agenda-refresh-files) - ;; C-x C-c means "close this frame" here. The global - ;; `save-buffers-kill-terminal' must never run in this frame: it was made - ;; by `make-frame', not emacsclient, so with no client to close it falls - ;; back to killing the daemon itself. - (define-key map (kbd "C-x C-c") #'cj/--agenda-frame-close) - ;; (d) Input machinery punched through the catch-all. An explicit nil - ;; shadows the [t] default in this map, so these fall through to their - ;; global bindings. Without the punches, every frame-focus change - ;; (switch-frame), every wheel scroll, and every mouse click hits the - ;; deny handler -- message spam and broken frame switching. - (dolist (key (list [switch-frame] - [wheel-up] [wheel-down] [wheel-left] [wheel-right] - [double-wheel-up] [double-wheel-down] - [triple-wheel-up] [triple-wheel-down] - [mouse-1] [down-mouse-1] [drag-mouse-1] - (kbd "C-h"))) - (define-key map key nil)) - ;; (e) Global chords that would pull focus out of the frame must be - ;; denied *explicitly*. The [t] catch-all can't reach them: a keymap's - ;; default binding does not shadow an *explicit* binding in a - ;; lower-priority map, and these are bound in the global map (M-SPC / - ;; M-S-SPC swap ai-term agents). Left to the catch-all, M-SPC follows - ;; its global binding and escapes the read-only frame into ai-term. - (dolist (key '("M-SPC" "M-S-SPC")) - (define-key map (kbd key) #'cj/--agenda-frame-denied-readonly)) - ;; The remaining view-changers get the distinct fixed-view message, not the - ;; read-only one. d/w are handled above (they toggle the span in place). - (dolist (key '("y" "f" "b" "j")) - (define-key map (kbd key) #'cj/--agenda-frame-denied-fixed-view)) - map) - "Keymap for `cj/agenda-frame-mode'. -Shadows `org-agenda-mode-map' by default-deny: the `[t]' catch-all denies -every key that is not explicitly allowlisted here, so a future Org binding -is denied by default and there is nothing to keep in sync.") - -(define-minor-mode cj/agenda-frame-mode - "Read-only, focus-locked policy for the dedicated agenda frame. -Only the allowlist in `cj/agenda-frame-mode-map' is permitted: navigation, -the engage/open keys (routed to the working frame), and the frame's own -controls. Every other key/mouse command is denied. The enforcement -boundary is keys and mouse; a direct \\[execute-extended-command] is out -of contract." - :init-value nil - :lighter " AgendaFrame" - :keymap cj/agenda-frame-mode-map) - -(defun cj/--agenda-frame-shadow-mutations (&optional source-map prefix) - "Deny every SOURCE-MAP key sequence not on the frame map's allowlist. -Walk SOURCE-MAP (default `org-agenda-mode-map') recursively. For each -sequence it binds to a command, if `cj/agenda-frame-mode-map' doesn't already -bind that sequence to a command or manage it as a prefix, add an explicit -read-only deny. - -This closes the default-deny hole: a keymap's `[t]' default never shadows an -explicit binding in a lower-priority map, so a single `[t]' catch-all denies -only keys that are unbound everywhere. Every key `org-agenda-mode-map' binds -\(t, I, k, z, s, ., the C-c mutators, C-x C-s, ...) would otherwise sail -through the catch-all and mutate source files from the read-only frame. -Explicitly denying each non-allowlisted sequence makes the catch-all's intent -actually hold. - -PREFIX is the accumulated key vector during recursion (internal). Idempotent: -re-running rebinds the same denials. Runs from `with-eval-after-load' once -`org-agenda-mode-map' exists." - (let ((source (or source-map org-agenda-mode-map)) - (prefix (or prefix []))) - (map-keymap - (lambda (event binding) - (unless (or (eq event t) (eq event 'menu-bar) (eq event 'remap) - (consp event)) - (let ((seq (vconcat prefix (vector event)))) - (cond - ((keymapp binding) - (cj/--agenda-frame-shadow-mutations binding seq)) - ((commandp binding) - (let ((ours (lookup-key cj/agenda-frame-mode-map seq))) - ;; A command we allowlisted or a prefix we manage: leave it. - ;; Anything else (only the `[t]' default, or unbound under a - ;; shared prefix) escapes to org's command -- deny it here. - (unless (or (commandp ours) (keymapp ours)) - (define-key cj/agenda-frame-mode-map seq - #'cj/--agenda-frame-denied-readonly)))))))) - source))) - -;; The shadow walk is installed at the END of this file, not here: it reads -;; `commandp' on each allowlisted binding to decide whether to keep it, and the -;; view/redo handlers (day-view, week-view, safe-redo) are defined further down. -;; If org-agenda is already loaded when this file loads (the normal startup order, -;; and every reload), `with-eval-after-load' fires immediately -- so the walk must -;; not run until those defuns exist, or it reads them as undefined, fails the -;; commandp guard, and denies the very keys the allowlist grants. See the bottom -;; of the file. - -(defun cj/--agenda-frame-maybe-enable-mode () - "Re-enable `cj/agenda-frame-mode' after an agenda build in the agenda frame. -Added to `org-agenda-finalize-hook'. `org-agenda-redo' rebuilds through -`org-agenda-mode', whose `kill-all-local-variables' strips the buffer-local -minor mode; this reinstates it whenever the just-built buffer is displayed -in the frame carrying the `cj/agenda-frame' marker (a frame parameter, which -survives the buffer reset). Ordinary agenda builds in working frames are -left untouched. - -The same reset also strips the buffer-local `kill-buffer-hook' installed at -spawn, so it is re-added here too -- otherwise, after the first refresh -tick, killing the buffer would no longer delete the frame." - (let ((frame (cj/--agenda-frame))) - (when (and frame (get-buffer-window (current-buffer) frame)) - (cj/agenda-frame-mode 1) - (add-hook 'kill-buffer-hook #'cj/--agenda-frame-on-kill-buffer nil t)))) - -;;; Frame lifecycle — spawn, raise, delete, toggle, cleanup - -(defconst cj/--agenda-frame-timer-parameter 'cj/agenda-frame-timer - "Frame parameter holding the agenda frame's refresh timer (set in Phase 2).") - -(declare-function auto-dim-other-buffers-mode "auto-dim-other-buffers" (&optional arg)) - -(defvar cj/--agenda-frame-dim-was-on nil - "Non-nil when the agenda frame's spawn turned `auto-dim-other-buffers-mode' off. -The refresh tick's selection swing marks the working window non-selected, -and auto-dim's debounced dim lands after the tick -- the working frame -visibly dims every five minutes. Spawn suspends the mode and remembers it -here; closing the frame restores it.") - -(defun cj/--agenda-frame-suspend-dim () - "Turn auto-dim off for the agenda frame's lifetime, remembering it was on." - (when (and (bound-and-true-p auto-dim-other-buffers-mode) - (fboundp 'auto-dim-other-buffers-mode)) - (setq cj/--agenda-frame-dim-was-on t) - (auto-dim-other-buffers-mode -1))) - -(defun cj/--agenda-frame-restore-dim () - "Restore auto-dim if the agenda frame's spawn suspended it." - (when (and cj/--agenda-frame-dim-was-on - (fboundp 'auto-dim-other-buffers-mode)) - (setq cj/--agenda-frame-dim-was-on nil) - (auto-dim-other-buffers-mode 1))) - -(defvar cj/--agenda-frame-tearing-down nil - "Non-nil while the agenda frame is being torn down. -Breaks the `delete-frame' / `kill-buffer-hook' re-entrancy loop: deleting -the frame kills its buffer and killing the buffer deletes the frame, so -whichever fires first sets this to skip the other.") - -(defun cj/--agenda-frame-sticky-buffer () - "Return the dedicated *Org Agenda(F)* sticky buffer, or nil if none." - (get-buffer (format "*Org Agenda(%s)*" cj/--agenda-frame-command-key))) - -(defun cj/--agenda-frame-cancel-timer (&optional frame) - "Cancel and clear the refresh timer on FRAME (default: the agenda frame). -Safe when no timer is set or FRAME is dead. Returns nil." - (let* ((frame (or frame (cj/--agenda-frame))) - (timer (and (frame-live-p frame) - (frame-parameter frame cj/--agenda-frame-timer-parameter)))) - (when (timerp timer) - (cancel-timer timer)) - (when (frame-live-p frame) - (set-frame-parameter frame cj/--agenda-frame-timer-parameter nil)) - nil)) - -(defun cj/--agenda-frame-on-delete-frame (frame) - "Clean up when the agenda FRAME dies by any path. -Registered on `delete-frame-functions': cancels the refresh timer and -kills the dedicated sticky buffer, so the next spawn regenerates fresh -rather than reusing stale sticky content. A non-agenda frame is ignored." - (when (cj/--agenda-frame-p frame) - (cj/--agenda-frame-cancel-timer frame) - (cj/--agenda-frame-restore-dim) - (let ((buffer (cj/--agenda-frame-sticky-buffer)) - (cj/--agenda-frame-tearing-down t)) - (when (buffer-live-p buffer) - (kill-buffer buffer))))) - -(defun cj/--agenda-frame-on-kill-buffer () - "Delete the agenda frame when its dedicated buffer is killed. -A buffer-local `kill-buffer-hook' on the sticky buffer, so killing it from -anywhere takes the frame with it. Guarded against re-entry during a -frame-initiated teardown." - (unless cj/--agenda-frame-tearing-down - (let ((frame (cj/--agenda-frame))) - (when (frame-live-p frame) - (delete-frame frame))))) - -(defun cj/--agenda-frame-delete () - "Delete the agenda frame; a no-op when none exists. -`delete-frame' fires `cj/--agenda-frame-on-delete-frame', which cancels -the timer and kills the sticky buffer." - (let ((frame (cj/--agenda-frame))) - (when (frame-live-p frame) - (delete-frame frame)))) - -(defun cj/--agenda-frame-raise (frame) - "Raise FRAME and give it input focus. Returns FRAME." - (select-frame-set-input-focus frame) - frame) - -(defun cj/--agenda-frame-make-parameters () - "Return the frame parameters for the dedicated agenda frame. -A normal frame -- not fullscreen -- so a tiling window manager places it -side by side with the working frame rather than covering the whole output. -It carries the `cj/agenda-frame' marker and a distinct, noticeable name -\(\"Full Agenda\") so the frame is recognizable at a glance and -window-manager rules can target it." - `((,cj/--agenda-frame-parameter . t) - (name . "Full Agenda"))) - -(defun cj/--agenda-frame-spawn () - "Create, display, and focus the dedicated agenda frame. -Transactional: on any failure after `make-frame', delete the partial -frame (which cleans up its buffer and timer via the delete hook), restore -focus to the launching frame, and signal a `user-error' naming the cause. -Returns the new agenda frame on success." - (let ((launch (selected-frame)) - (frame nil)) - (condition-case err - (progn - (setq cj/--agenda-frame-launch-frame launch) - ;; A fresh frame opens at the documented seven-day default, even if a - ;; prior session left the span on the day view (d). - (setq cj/--agenda-frame-span 7) - (setq frame (make-frame (cj/--agenda-frame-make-parameters))) - (select-frame-set-input-focus frame) - ;; Cached, non-forced: a frame spawned early after daemon startup - ;; still shows the full project agenda, not the base-files-only view. - (cj/build-org-agenda-list) - ;; Bind sticky + current-window dynamically around the render. The - ;; custom command's own settings apply too late to name the buffer; - ;; without these the buffer is plain *Org Agenda*, which matches the - ;; 0.75 below-selected display rule in org-agenda-config.el -- the - ;; new frame gets split with the launch buffer left in the top 25%. - ;; Sticky names it *Org Agenda(F)*, which no display rule matches. - (let ((org-agenda-sticky t) - (org-agenda-window-setup 'current-window)) - (org-agenda "a" cj/--agenda-frame-command-key)) - ;; Belt: whatever a display rule did, the frame is one agenda window. - (delete-other-windows) - (let ((buffer (cj/--agenda-frame-sticky-buffer))) - (when (buffer-live-p buffer) - (with-current-buffer buffer - (add-hook 'kill-buffer-hook - #'cj/--agenda-frame-on-kill-buffer nil t)))) - (cj/--agenda-frame-start-timer frame) - (cj/--agenda-frame-suspend-dim) - frame) - (error - (when (frame-live-p frame) - (delete-frame frame)) - (when (frame-live-p launch) - (select-frame-set-input-focus launch)) - (user-error "Agenda frame: spawn failed: %s" - (error-message-string err)))))) - -(defun cj/--agenda-frame-toggle () - "Spawn, raise, or delete the dedicated agenda frame. -Spawn when none exists, delete when the agenda frame is the selected -frame, raise and focus it otherwise. - -Non-interactive by design in Phase 1: reachable only from ERT, never from -\\[execute-extended-command] or a key. Phase 2 wraps this in the public -`cj/agenda-frame-toggle' and binds it to S-<f8>." - (let ((frame (cj/--agenda-frame))) - (cond - ((null frame) (cj/--agenda-frame-spawn)) - ((eq frame (selected-frame)) (cj/--agenda-frame-delete) nil) - (t (cj/--agenda-frame-raise frame))))) - -;;; Phase 2 — refresh timer, snapshot restore, and the public command - -(defconst cj/--agenda-frame-refresh-seconds 300 - "Refresh cadence for the agenda frame, in seconds (five minutes).") - -(defconst cj/--agenda-frame-fail-count-parameter 'cj/agenda-frame-fail-count - "Frame parameter holding the consecutive-failure count for the refresh timer.") - -(defconst cj/--agenda-frame-overlay-property 'cj/agenda-frame-failure - "Overlay property tagging the refresh-failed banner. -The banner is found by scanning for this property, never held in a -buffer-local variable: `org-agenda-redo' runs `kill-all-local-variables', -which would wipe the variable while the overlay object survives -`erase-buffer' -- leaving a banner nothing could ever remove.") - -(defun cj/--agenda-frame-seconds-to-next-mark (time period) - "Return seconds from TIME to the next wall-clock multiple of PERIOD. -TIME is any Emacs time value, PERIOD is seconds (300 gives the :00/:05 -marks). A TIME exactly on a mark returns a full PERIOD, so the timer -never fires twice back-to-back." - (let ((rem (mod (floor (float-time time)) period))) - (if (zerop rem) period (- period rem)))) - -;; -- Point restoration ------------------------------------------------------- - -(defun cj/--agenda-frame-goto-first-item () - "Move point to the first agenda item, or `point-min' when the view is empty." - (goto-char (point-min)) - (let ((found nil)) - (while (and (not found) (not (eobp))) - (if (get-text-property (line-beginning-position) 'org-marker) - (setq found t) - (forward-line 1))) - (unless found (goto-char (point-min))))) - -(defun cj/--agenda-frame-restore-point (old-marker old-line) - "Restore point in the rebuilt agenda buffer after a redo. -Prefer the line whose org-marker points at the same source location as -OLD-MARKER, choosing the occurrence nearest OLD-LINE when a source line -appears twice. When the marker is gone, clamp OLD-LINE into range; if -that lands on a header (no item), move to the first item; an item-less -view leaves point at buffer start." - (let ((max-line (line-number-at-pos (point-max))) - (targets '())) - (when (and (markerp old-marker) (marker-buffer old-marker)) - (let ((src-buf (marker-buffer old-marker)) - (src-pos (marker-position old-marker))) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (let ((m (get-text-property (line-beginning-position) 'org-marker))) - (when (and (markerp m) - (eq (marker-buffer m) src-buf) - (eql (marker-position m) src-pos)) - (push (line-number-at-pos) targets))) - (forward-line 1))))) - (cond - (targets - (let ((best (car (sort targets - (lambda (a b) - (< (abs (- a old-line)) (abs (- b old-line)))))))) - (goto-char (point-min)) - (forward-line (1- best)))) - (t - (let ((line (max 1 (min old-line max-line)))) - (goto-char (point-min)) - (forward-line (1- line)) - (unless (get-text-property (line-beginning-position) 'org-marker) - (cj/--agenda-frame-goto-first-item))))))) - -;; -- Snapshot with cloned markers -------------------------------------------- - -(defun cj/--agenda-frame-snapshot-markers (buffer) - "Return a list of (POSITION . CLONE) for every org-marker in BUFFER. -CLONE is an independent `copy-marker' into the same source location, so -it survives `org-agenda-reset-markers' nulling BUFFER's own markers on a -rebuild." - (with-current-buffer buffer - (let ((clones '()) - (pos (point-min))) - (while (< pos (point-max)) - (let ((m (get-text-property pos 'org-marker))) - (when (and (markerp m) (marker-buffer m)) - (push (cons pos (copy-marker m)) clones))) - (setq pos (or (next-single-property-change pos 'org-marker buffer) - (point-max)))) - (nreverse clones)))) - -(defun cj/--agenda-frame-reinstall-markers (buffer clones) - "Reapply CLONES (from `cj/--agenda-frame-snapshot-markers') to BUFFER. -Restores each cloned marker as the org-marker text property at its -recorded position, so RET/TAB resolve to the right source line after a -snapshot restore." - (with-current-buffer buffer - (dolist (entry clones) - (let ((pos (car entry))) - (when (and (>= pos (point-min)) (< pos (point-max))) - (put-text-property pos (1+ pos) 'org-marker (cdr entry))))))) - -(defun cj/--agenda-frame-snapshot (buffer window) - "Capture BUFFER's last-good state for restore after a failed redo. -Returns a plist of the propertized :text (carrying org-redo-cmd/org-lprops), -:point, :window-start, and :markers (cloned, source-owned)." - (with-current-buffer buffer - (list :text (buffer-substring (point-min) (point-max)) - :point (point) - :window-start (and (window-live-p window) (window-start window)) - :markers (cj/--agenda-frame-snapshot-markers buffer)))) - -(defun cj/--agenda-frame-restore-snapshot (buffer snapshot window) - "Restore SNAPSHOT verbatim into BUFFER, reinstating cloned markers. -Sets point and, when WINDOW is live, window-start from the snapshot." - (with-current-buffer buffer - (let ((inhibit-read-only t)) - (erase-buffer) - (insert (plist-get snapshot :text)) - (cj/--agenda-frame-reinstall-markers buffer (plist-get snapshot :markers)) - (goto-char (min (plist-get snapshot :point) (point-max)))) - (when (and (window-live-p window) (plist-get snapshot :window-start)) - (set-window-start window (min (plist-get snapshot :window-start) - (point-max)))))) - -(defun cj/--agenda-frame-release-snapshot (snapshot) - "Release SNAPSHOT's cloned markers so repeated redoes don't leak markers. -Called on a successful redo (the snapshot is discarded); never on the -error path, where the clones become the buffer's live org-markers." - (dolist (entry (plist-get snapshot :markers)) - (when (markerp (cdr entry)) - (set-marker (cdr entry) nil)))) - -;; -- Failure latch and overlay ----------------------------------------------- - -(defun cj/--agenda-frame-record-failure (frame) - "Increment FRAME's consecutive-failure count; return non-nil to report. -Reports only on the first failure of a run (the 0 -> 1 transition)." - (let ((n (1+ (or (frame-parameter frame cj/--agenda-frame-fail-count-parameter) - 0)))) - (set-frame-parameter frame cj/--agenda-frame-fail-count-parameter n) - (= n 1))) - -(defun cj/--agenda-frame-clear-failure (frame) - "Reset FRAME's consecutive-failure count (the next tick reports again)." - (set-frame-parameter frame cj/--agenda-frame-fail-count-parameter 0)) - -(defun cj/--agenda-frame-failure-overlays (buffer) - "Return the refresh-failed banner overlays in BUFFER (normally 0 or 1)." - (with-current-buffer buffer - (seq-filter (lambda (o) (overlay-get o cj/--agenda-frame-overlay-property)) - (overlays-in (point-min) (point-max))))) - -(defun cj/--agenda-frame-show-failure-overlay (buffer) - "Show the refresh-failed notice as an overlay at the top of BUFFER. -Idempotent: an existing banner is reused, so consecutive failures never -stack a second one." - (with-current-buffer buffer - (let ((overlay (or (car (cj/--agenda-frame-failure-overlays buffer)) - (make-overlay (point-min) (point-min))))) - (overlay-put overlay cj/--agenda-frame-overlay-property t) - (overlay-put overlay 'before-string - (propertize "Agenda frame: refresh failed (C-M-<f8> to force-rescan)\n" - 'face 'warning))))) - -(defun cj/--agenda-frame-remove-overlay (buffer) - "Remove the refresh-failed banner from BUFFER, if present." - (when (buffer-live-p buffer) - (mapc #'delete-overlay (cj/--agenda-frame-failure-overlays buffer)))) - -;; -- The refresh itself ------------------------------------------------------ - -(defun cj/--agenda-frame-do-redo (frame buffer window) - "Redo the agenda in BUFFER, degrading to the last-good snapshot on failure. -On success: drop the failure overlay, restore point, clear the failure -latch, and release the pre-redo snapshot. On error: restore the snapshot -verbatim, re-enable the policy (the finalize hook runs only on success), -show the failure overlay, and report once per consecutive-failure run. -Either way the frame is never blank, unrestricted, or non-retryable." - (with-current-buffer buffer - ;; Clone the point marker: `org-agenda-redo' calls `org-agenda-reset-markers' - ;; which nulls the buffer's own org-markers, so the raw marker would be dead - ;; by the time `cj/--agenda-frame-restore-point' runs -- collapsing the - ;; "follow the same source item" restoration to the line-number clamp on - ;; every normal tick. An independent clone survives the reset. - (let ((old-marker (let ((m (cj/--agenda-frame-item-marker))) - (and (markerp m) (marker-buffer m) (copy-marker m)))) - (old-line (line-number-at-pos)) - (snapshot (cj/--agenda-frame-snapshot buffer window))) - (unwind-protect - (condition-case nil - ;; Never bind sticky here: `org-agenda-redo' handles the - ;; in-place rebuild itself (binds sticky nil, redirects the - ;; buffer name). A sticky t reaching `org-agenda-prepare' - ;; mid-redo makes it throw \\='exit with no catch, failing - ;; every tick. current-window is bound as a belt so a rule - ;; can't split the frame during the rebuild. - (let ((inhibit-message t) - (org-agenda-window-setup 'current-window)) - (org-agenda-redo) - (cj/--agenda-frame-remove-overlay buffer) - (cj/--agenda-frame-restore-point old-marker old-line) - (cj/--agenda-frame-clear-failure frame) - (cj/--agenda-frame-release-snapshot snapshot)) - (error - (cj/--agenda-frame-restore-snapshot buffer snapshot window) - (cj/agenda-frame-mode 1) - (cj/--agenda-frame-show-failure-overlay buffer) - (when (cj/--agenda-frame-record-failure frame) - (message "Agenda frame: refresh failed (C-M-<f8> to force-rescan)")))) - (when (markerp old-marker) - (set-marker old-marker nil)))))) - -(defun cj/--agenda-frame-safe-redo (&optional frame) - "Refresh the agenda buffer in FRAME safely (the timer tick and manual `r'). -Runs with the dedicated window selected for the redo's dynamic extent and -restores the prior window afterward, never calling an input-focus -function, so a tick while another frame is active neither errors on an -out-of-range window-start nor steals focus." - (interactive) - (let* ((frame (or frame (cj/--agenda-frame))) - (buffer (cj/--agenda-frame-sticky-buffer)) - (window (and (frame-live-p frame) (buffer-live-p buffer) - (get-buffer-window buffer frame)))) - (when (and (window-live-p window) - ;; Skip the tick while a minibuffer is active anywhere -- - ;; reselecting windows under an active minibuffer session can - ;; break it, and the next tick catches up. - (not (active-minibuffer-window))) - (let ((prev-window (selected-window)) - ;; The rebuild takes visible time, and for its duration the - ;; agenda window is the selected window. Without inhibiting - ;; redisplay the user's cursor visibly goes hollow for the whole - ;; rebuild every tick -- indistinguishable from focus theft. - ;; The rebuild blocks Emacs either way (it is synchronous), so - ;; this hides the selection flicker at no extra cost; redisplay - ;; resumes after the selection is restored. - (inhibit-redisplay t)) - (unwind-protect - (progn - (select-window window t) - (cj/--agenda-frame-do-redo frame buffer window)) - (when (window-live-p prev-window) - (select-window prev-window t))))))) - -(defun cj/--agenda-frame-day-view () - "Shrink the Full Agenda frame to today's single-day view. -Sets the span to 1 and refreshes. The redo re-evaluates the span, so the -day view survives the wall-clock refresh tick until `w' widens it again." - (interactive) - (setq cj/--agenda-frame-span 1) - (cj/--agenda-frame-safe-redo)) - -(defun cj/--agenda-frame-week-view () - "Restore the Full Agenda frame to the seven-day today-anchored view. -Sets the span back to 7 and refreshes." - (interactive) - (setq cj/--agenda-frame-span 7) - (cj/--agenda-frame-safe-redo)) - -(defun cj/--agenda-frame-start-timer (frame) - "Start FRAME's five-minute wall-clock refresh timer, unless one exists. -Idempotent: a frame already carrying a live timer keeps it (no duplicate). -Returns the timer." - (unless (timerp (frame-parameter frame cj/--agenda-frame-timer-parameter)) - (let* ((period cj/--agenda-frame-refresh-seconds) - (delay (cj/--agenda-frame-seconds-to-next-mark (current-time) period)) - (timer (run-at-time delay period #'cj/--agenda-frame-safe-redo frame))) - (set-frame-parameter frame cj/--agenda-frame-timer-parameter timer) - timer))) - -;; -- Public command and key install ------------------------------------------ - -(defun cj/agenda-frame-toggle () - "Toggle the dedicated agenda frame. -Spawn it when none exists, raise and focus it when it exists but is -unfocused, and close it when it is the selected frame." - (interactive) - (cj/--agenda-frame-toggle)) - -(defun cj/--agenda-frame-install-keys (&optional map) - "Bind the F8-family keys for the agenda frame in MAP (default: the global map). -S-<f8> toggles the agenda frame; the force-rescan -\(`cj/org-agenda-refresh-files') moves to C-M-<f8>, keeping the whole -force-refresh idea in the F8 family." - (let ((map (or map (current-global-map)))) - (define-key map (kbd "S-<f8>") #'cj/agenda-frame-toggle) - (define-key map (kbd "C-M-<f8>") #'cj/org-agenda-refresh-files))) - -;;; Wiring — registered once org-agenda is loaded (no batch side effects) - -(with-eval-after-load 'org-agenda - (cj/--agenda-frame-register-command) - (add-hook 'org-agenda-finalize-hook #'cj/--agenda-frame-maybe-enable-mode) - (add-hook 'delete-frame-functions #'cj/--agenda-frame-on-delete-frame)) - -;; The public gesture appears only now that the feature is complete and live. -(cj/--agenda-frame-install-keys) - -;; Install the read-only shadow now that every allowlist handler above is -;; defined, so the walk's `commandp' guard recognizes them and preserves the -;; allowlist regardless of whether org-agenda loaded before or after this file. -(with-eval-after-load 'org-agenda - (cj/--agenda-frame-shadow-mutations)) - -(provide 'org-agenda-frame) -;;; org-agenda-frame.el ends here diff --git a/modules/org-config.el b/modules/org-config.el index a9fc4811..55fdf1d0 100644 --- a/modules/org-config.el +++ b/modules/org-config.el @@ -16,6 +16,7 @@ ;;; Code: (require 'keybindings) ;; provides cj/custom-keymap (used in :init below) +(require 'user-constants) ;; provides cj/org-todo-keywords (used in :config) ;; Declare org variables and functions used before org is loaded so this module ;; byte-compiles standalone. Plain `defvar' (no value) marks the symbol special @@ -284,10 +285,9 @@ a no-op identical-state transition (see `cj/org--noop-state-log-p')." "All org-todo related settings are grouped and set in this function." ;; logging task creation, task start, and task resolved states - (setq org-todo-keywords '((sequence "TODO(t)" "PROJECT(p)" "DOING(i)" - "WAITING(w)" "VERIFY(v)" "STALLED(s)" - "DELEGATED(x)" "|" - "FAILED(f!)" "DONE(d!)" "CANCELLED(c!)"))) + ;; Defined in user-constants so a batch Emacs can load the sequence without + ;; this module's package dependencies. See `cj/org-todo-keywords'. + (setq org-todo-keywords cj/org-todo-keywords) ;; Keyword and priority faces are defined and wired in org-faces-config.el ;; (loaded just after this module): each keyword and priority maps to its own diff --git a/modules/package-resilience.el b/modules/package-resilience.el new file mode 100644 index 00000000..d81eeec0 --- /dev/null +++ b/modules/package-resilience.el @@ -0,0 +1,369 @@ +;;; package-resilience.el --- Survive failed package installs at startup -*- lexical-binding: t -*- + +;;; Commentary: +;; A transient package download must not abort init. +;; +;; `use-package-ensure-elpa' already handles a failed install correctly: it +;; wraps `package-install' in `condition-case-unless-debug', and on error it +;; warns and carries on. That guard does nothing whenever `debug-on-error' is +;; non-nil, and early-init.el sets `debug-on-error' for the whole of startup so +;; my own config errors are loud. The two settings collide. On a fresh +;; install one dead download — a file-error from an ELPA host — escaped into +;; the debugger and stopped init in place, leaving a third of the config +;; loaded and hooks pointing at packages that were never installed. +;; +;; I keep both behaviors by narrowing the loud-errors setting rather than +;; dropping it: package installation runs with the debugger inhibited, +;; everything else in init still gets it. A package that will not install is +;; recorded and reported at the end of startup instead of stopping it. + +;;; Code: + +(require 'cl-lib) +(require 'package) +(require 'seq) +(require 'use-package-ensure) + +(defgroup cj/package-resilience nil + "Keep a failed package install from aborting Emacs startup." + :group 'cj + :prefix "cj/package-") + +(defcustom cj/package-install-retries 2 + "How many extra attempts a failed package install gets. +Retries exist for transient network failures, which is the common case on a +fresh install pulling every package over the wire." + :type 'integer + :group 'cj/package-resilience) + +(defcustom cj/package-install-retry-delay 2 + "Seconds to wait between package install attempts." + :type 'number + :group 'cj/package-resilience) + +(defcustom cj/package-install-retry-budget 60 + "Seconds this session may spend retrying installs, in total. +Retrying is worth it for a transient failure, which fails alone. A machine +that is simply offline fails every package instead, and without a ceiling the +per-package retry cost would be paid ~190 times over — trading the abort this +module removes for a startup that appears to hang. Once the budget is spent +each package still gets its one attempt, and still gets recorded." + :type 'number + :group 'cj/package-resilience) + +(defcustom cj/package-install-failure-limit 5 + "Consecutive failed installs after which this session stops attempting more. +The retry budget bounds retrying, but not the first attempt, and the first +attempt is where the cost lives when a machine is entirely offline: nothing +populates `package-archive-contents', so `use-package-ensure-elpa' runs a full +`package-refresh-contents' across every configured archive before each install +fails. Paid once per package across ~190 packages, that is a startup that +looks hung. Failures this many times in a row mean the network is gone rather +than one package being unlucky, so the rest are recorded without being tried." + :type 'integer + :group 'cj/package-resilience) + +(defvar cj/failed-package-installs nil + "Archive packages that did not install during this session.") + +(defvar cj/failed-source-package-installs nil + "Packages declared with `:vc' that did not install during this session. +Kept apart from `cj/failed-package-installs' because `package-install' cannot +recover them: some are on no archive at all, and one that happens to be on an +archive would be recovered as the archive build rather than the source +checkout that was asked for, silently and permanently.") + +(defvar cj/--package-retry-spent 0.0 + "Seconds spent retrying package installs so far this session.") + +(defvar cj/--package-consecutive-failures 0 + "How many packages have failed to install in a row.") + +;; ------------------------------ Resolving names ------------------------------ + +(defun cj/--package-as-symbol (name) + "Return NAME as a symbol, whether it arrives as a symbol or a string. +This mirrors `use-package-as-symbol' without depending on use-package-core +being loaded at the point early-init installs this." + (if (symbolp name) name (intern name))) + +(defun cj/--package-ensure-packages (name args) + "Return the package symbols a use-package form requests. +NAME is the form's name and ARGS the values of its :ensure keywords, in the +shape `use-package-ensure-elpa' receives them: t means the form's own name, a +symbol names another package, a cons cell is a pinned (PACKAGE . ARCHIVE), and +nil requests nothing." + (delq nil + (mapcar (lambda (ensure) + (let ((package (if (eq ensure t) + (cj/--package-as-symbol name) + ensure))) + (if (consp package) (car package) package))) + args))) + +(defun cj/--package-ensure-missing (name args) + "Return the packages NAME's :ensure ARGS request that are not installed." + (seq-remove #'package-installed-p (cj/--package-ensure-packages name args))) + +(defun cj/--package-any-retryable-p (packages) + "Return non-nil when some of PACKAGES is one an archive actually carries. +A name no archive has heard of will not appear on a retry either, so retrying +it only spends another refresh on a typo." + (seq-some (lambda (package) (assq package package-archive-contents)) packages)) + +;; -------------------------------- Installing --------------------------------- + +(defun cj/--package-ensure-once (name args state no-refresh) + "Make one install attempt for NAME's :ensure ARGS, with STATE and NO-REFRESH. +Binding `debug-on-error' to nil re-arms the `condition-case-unless-debug' +inside `use-package-ensure-elpa', which early-init's loud-errors setting +otherwise disables. The editing hooks are silenced because installing a +package generates autoloads by visiting .el files: a hook belonging to a +package that failed earlier would run there and break unrelated installs." + (let ((debug-on-error nil) + (find-file-hook nil) + (prog-mode-hook nil) + (lisp-data-mode-hook nil) + (emacs-lisp-mode-hook nil)) + (use-package-ensure-elpa name args state no-refresh))) + +(defun cj/--package-retry-budget-left-p () + "Return non-nil while this session may still spend time retrying installs." + (< cj/--package-retry-spent cj/package-install-retry-budget)) + +(defun cj/--package-ensure-retry (name args state no-refresh) + "Retry NAME's missing :ensure ARGS, passing STATE and NO-REFRESH through. +Stops once the session's retry budget is spent, or once nothing still missing +is carried by an archive." + (let ((left cj/package-install-retries)) + (while (and (> left 0) + (cj/--package-retry-budget-left-p) + (cj/--package-any-retryable-p (cj/--package-ensure-missing name args))) + (setq left (1- left)) + (let ((start (float-time))) + (sleep-for cj/package-install-retry-delay) + (cj/--package-ensure-once name args state no-refresh) + (setq cj/--package-retry-spent + (+ cj/--package-retry-spent (- (float-time) start))))))) + +(defun cj/--package-record-one (package) + "Record PACKAGE as one that did not install." + (when package + (cl-pushnew package cj/failed-package-installs))) + +(defun cj/--package-record-source-one (package) + "Record PACKAGE as a source install that did not complete." + (when package + (cl-pushnew package cj/failed-source-package-installs))) + +(defun cj/--package-record-failures (name args) + "Record any of NAME's :ensure ARGS that are still not installed." + (dolist (package (cj/--package-ensure-missing name args)) + (cj/--package-record-one package))) + +(defun cj/--package-giving-up-p () + "Return non-nil once enough installs have failed in a row to stop trying." + (>= cj/--package-consecutive-failures cj/package-install-failure-limit)) + +(defun cj/--package-note-outcome (name args) + "Count NAME's :ensure ARGS outcome toward the consecutive-failure run." + (if (cj/--package-ensure-missing name args) + (setq cj/--package-consecutive-failures + (1+ cj/--package-consecutive-failures)) + (setq cj/--package-consecutive-failures 0))) + +(defun cj/package-ensure (name args state &optional no-refresh) + "Install NAME's :ensure ARGS without letting a failure abort startup. +STATE and NO-REFRESH are passed through to `use-package-ensure-elpa'. This is +the value of `use-package-ensure-function'; see this file's commentary for why +the stock one cannot survive `debug-on-error'. + +A form whose packages are already present is left alone entirely, so it neither +costs anything nor tells us whether the network is up." + (cond + ((null (cj/--package-ensure-missing name args)) nil) + ((cj/--package-giving-up-p) (cj/--package-record-failures name args)) + (t + (cj/--package-ensure-once name args state no-refresh) + (cj/--package-ensure-retry name args state no-refresh) + (cj/--package-note-outcome name args) + (cj/--package-record-failures name args)))) + +;; ------------------------- Packages installed from source -------------------- + +;; A `:vc' form routes around everything above: use-package nulls :ensure +;; whenever :vc is present (use-package-ensure.el, `use-package-handler/:ensure'), +;; so `use-package-ensure-function' is never consulted. And +;; `use-package-vc-install' carries no error handling of its own, so a failed +;; clone signals straight into init under the loud-errors setting -- the +;; original bug, through a second door. A fresh machine without credentials +;; for the git host yet is exactly the case this module exists for, so the +;; clone gets the same treatment: quiet context, recorded, counted. + +(defun cj/--package-vc-install-once (orig arg local-path) + "Call ORIG with ARG and LOCAL-PATH, surviving a failed clone. +Returns non-nil when the clone worked. Unlike the :ensure path there is no +upstream `condition-case' to re-arm, so this supplies one." + (let ((debug-on-error nil) + (find-file-hook nil) + (prog-mode-hook nil) + (lisp-data-mode-hook nil) + (emacs-lisp-mode-hook nil)) + (condition-case err + (progn (funcall orig arg local-path) t) + (error + (display-warning + 'cj/package-resilience + (format "Failed to install %s from source: %s" + (car arg) (error-message-string err)) + :error) + nil)))) + +(defun cj/--package-vc-install-guard (orig arg &optional local-path) + "Around-advice for `use-package-vc-install', called as ORIG. +ARG is (NAME OPTIONS REVISION) and LOCAL-PATH is passed through." + (let ((package (car arg))) + (cond + ;; Already present: ORIG no-ops, and it would tell us nothing about + ;; whether the host is reachable, so the failure run is left alone. + ((and package (package-installed-p package)) + (funcall orig arg local-path)) + ((cj/--package-giving-up-p) + (cj/--package-record-source-one package)) + (t + (cj/--package-vc-install-once orig arg local-path) + (if (and package (package-installed-p package)) + (setq cj/--package-consecutive-failures 0) + (cj/--package-record-source-one package) + (setq cj/--package-consecutive-failures + (1+ cj/--package-consecutive-failures))))))) + +;; --------------------------------- Recovery ---------------------------------- + +(defun cj/package-still-missing () + "Return the recorded failures that are still not installed. +A package that failed on its own `use-package' form is often installed a +moment later as some other package's dependency, so the recorded list +overstates the damage until it is re-checked against reality." + ;; `append' does not copy its last argument and `delete-dups' splices + ;; destructively, so without the copy this read would edit + ;; `cj/failed-source-package-installs' in place -- and it runs from the + ;; startup report, where losing a record silently is the worst place for it. + (seq-remove #'package-installed-p + (delete-dups + (append cj/failed-package-installs + (copy-sequence cj/failed-source-package-installs))))) + +(defun cj/--package-install-quietly (package) + "Attempt to install PACKAGE. Return non-nil if it is installed afterward." + (unless (package-installed-p package) + (let ((debug-on-error nil) + (find-file-hook nil) + (prog-mode-hook nil) + (lisp-data-mode-hook nil) + (emacs-lisp-mode-hook nil)) + (condition-case err + (package-install package) + (error (message "package-resilience: %s still failing: %s" + package (error-message-string err)))))) + (package-installed-p package)) + +(defun cj/--package-retry-pass () + "Try every package in `cj/failed-package-installs' once. +Return how many were installed on this pass." + (let ((installed 0)) + ;; Only the archive list. Source packages are kept out of it entirely, so + ;; no filter is needed here -- and a filter would be actively wrong: on a + ;; first boot before the network came up nothing has populated + ;; `package-archive-contents', so screening on it would skip every recorded + ;; package and make this command a silent no-op in the case it exists for. + ;; `package-install' populates the archives itself when it needs to. + (dolist (package (copy-sequence cj/failed-package-installs)) + (when (cj/--package-install-quietly package) + (setq cj/failed-package-installs + (delq package cj/failed-package-installs)) + (setq installed (1+ installed)))) + installed)) + +(defun cj/retry-failed-package-installs () + "Install everything that failed earlier, passing over the set until it settles. +A failed package leaves hooks that break other installs, so one package +succeeding can unblock others. Passes repeat while any pass installs +something, which also terminates: a pass that installs nothing ends it." + (interactive) + ;; Asking for a retry asserts the network may be back, so clear the run that + ;; stopped this session attempting installs in the first place. + (setq cj/--package-consecutive-failures 0) + (while (> (cj/--package-retry-pass) 0)) + (when (called-interactively-p 'interactive) + (let ((missing (cj/package-still-missing))) + (message (if missing + (format "Still missing: %s" + (mapconcat #'symbol-name missing " ")) + "All packages installed."))))) + +(defun cj/report-failed-package-installs () + "Warn about packages that failed to install, naming every one of them. +Only packages that are still absent are named; one that arrived later as +another package's dependency is not a failure the user needs to act on." + (let* ((missing (cj/package-still-missing)) + (source (seq-filter (lambda (p) + (memq p cj/failed-source-package-installs)) + missing)) + (archive (seq-difference missing source))) + (when missing + (display-warning + 'cj/package-resilience + (concat + (format "%d package(s) are missing: %s +Startup continued without them, so features they back are missing." + (length missing) (mapconcat #'symbol-name missing ", ")) + ;; Two different recoveries, so name which packages each one covers. + ;; Sending the user to the retry command for a source package wastes + ;; their time every startup: it cannot install one. + (when archive + (format " +Run M-x cj/retry-failed-package-installs for: %s" + (mapconcat #'symbol-name archive ", "))) + (when source + (format " +These install from source, so they need working credentials for the git host +and then 'make bootstrap': %s" + (mapconcat #'symbol-name source ", "))) + (when (cj/--package-giving-up-p) + (format " +Installing stopped after %d failures in a row, so most of these were never +attempted. Check the network and your credentials for the git host." + cj/package-install-failure-limit))) + :error)))) + +;; -------------------------------- Bootstrap ---------------------------------- + +(defun cj/package-bootstrap-batch () + "Entry point for the bootstrap script: retry, report, and exit. +Loading init.el in batch installs whatever `use-package' asks for; this retries +anything that pass missed and turns the outcome into an exit status the shell +can loop on. Exits 0 when nothing is missing, 1 otherwise." + (cj/retry-failed-package-installs) + (let ((missing (cj/package-still-missing))) + (if missing + (progn + (message "package-bootstrap: %d missing: %s" + (length missing) + (mapconcat #'symbol-name missing " ")) + (kill-emacs 1)) + (message "package-bootstrap: all packages installed") + (kill-emacs 0)))) + +;; --------------------------------- Wiring ------------------------------------ + +(setq use-package-ensure-function #'cj/package-ensure) + +;; Named function, never a lambda: an anonymous advice cannot be removed by +;; reference, so a live daemon would keep running it after the form is deleted. +(advice-add 'use-package-vc-install :around #'cj/--package-vc-install-guard) + +(add-hook 'emacs-startup-hook #'cj/report-failed-package-installs 90) + +(provide 'package-resilience) +;;; package-resilience.el ends here diff --git a/modules/prog-general.el b/modules/prog-general.el index a1377160..e9586a97 100644 --- a/modules/prog-general.el +++ b/modules/prog-general.el @@ -39,6 +39,7 @@ ;;; Code: (require 'user-constants) ;; code-dir, projects-dir, snippets-dir +(require 'cl-lib) (defvar display-line-numbers-type) (defvar outline-minor-mode-map) @@ -57,6 +58,7 @@ (declare-function dired-get-filename "dired") (declare-function global-treesit-auto-mode "treesit-auto") (declare-function treesit-auto-add-to-auto-mode-alist "treesit-auto") +(declare-function treesit-auto-install-all "treesit-auto") (declare-function treesit-auto-recipe-lang "treesit-auto") (declare-function highlight-indent-guides-mode "highlight-indent-guides") (declare-function electric-pair-default-inhibit "elec-pair") @@ -117,23 +119,32 @@ REGEXP must be a string or an rx form." ;; Manages tree-sitter grammars. Install is 'prompt, never t: with t, ;; merely opening a file could trigger a network download and a compiler -;; build mid-edit. Batch/test runs never load treesit-auto (no package -;; init), so they can never install. Fresh-machine bootstrap is the -;; explicit `cj/install-treesit-grammars' command below. +;; build mid-edit. `make test' runs with no package init and so never +;; loads treesit-auto, but a test file that calls `package-initialize' +;; itself does load it, and a tree-sitter mode then prompts for a missing +;; grammar; such tests must skip on `treesit-ready-p'. Fresh-machine +;; bootstrap is the explicit `cj/install-treesit-grammars' command below. +(defun cj/treesit-auto-pin-go-revision (recipes) + "Pin the Go grammar revision in treesit-auto RECIPES. +Return the updated Go recipe, or nil when RECIPES has no Go entry. +Discover the `revision' slot at runtime because treesit-auto is not loaded +when this file's `use-package' form is macro-expanded." + (when-let ((go-recipe + (cl-find-if + (lambda (recipe) + (eq (treesit-auto-recipe-lang recipe) 'go)) + recipes))) + (aset go-recipe + (cl-struct-slot-offset 'treesit-auto-recipe 'revision) + "v0.19.1") + go-recipe)) + (use-package treesit-auto :custom (treesit-auto-install 'prompt) :config - (require 'cl-lib) ;; Pin Go grammar to v0.19.1 for compatibility with Emacs 30.2 font-lock queries - (let* ((go-idx (cl-position-if (lambda (recipe) - (eq (treesit-auto-recipe-lang recipe) 'go)) - treesit-auto-recipe-list)) - (go-recipe (and go-idx (nth go-idx treesit-auto-recipe-list)))) - (when go-recipe - ;; Use the struct accessor so a treesit-auto slot reorder can't silently - ;; write the pin into the wrong field. - (setf (treesit-auto-recipe-revision go-recipe) "v0.19.1"))) + (cj/treesit-auto-pin-go-revision treesit-auto-recipe-list) (treesit-auto-add-to-auto-mode-alist 'all) (global-treesit-auto-mode)) diff --git a/modules/system-commands.el b/modules/system-commands.el index edc6339d..08a1be5d 100644 --- a/modules/system-commands.el +++ b/modules/system-commands.el @@ -39,7 +39,7 @@ ;; require keeps the module loadable on its own (tests, byte-compile) rather ;; than relying on init.el's load order. (require 'host-environment) -;; `system-lib' provides `cj/confirm-strong', used at runtime by the `strong' +;; `system-lib' provides `cj/confirm-destructive', used at runtime by the `strong' ;; confirm branch of `cj/system-cmd' for irreversible actions (shutdown/reboot). (require 'system-lib) (eval-when-compile (require 'subr-x)) @@ -76,10 +76,11 @@ If CMD is deemed dangerous, ask for confirmation." (label (nth 2 resolved))) (let ((confirm (and sym (get sym 'cj/system-confirm)))) (cond - ;; Strong confirm for irreversible actions (shutdown, reboot): - ;; require an explicit "yes", so a stray RET/space can't trigger them. + ;; Strong confirm for irreversible actions (shutdown, reboot): one + ;; keystroke, but with no default, so a stray RET/space can't trigger + ;; them and type-ahead is discarded before the read. ((eq confirm 'strong) - (unless (cj/confirm-strong (format "Really run %s (%s)? " label cmdstr)) + (unless (cj/confirm-destructive (format "Really run %s (%s)? " label cmdstr)) (user-error "Aborted"))) ;; Quick (Y/n) confirm for recoverable actions (logout, suspend). (confirm @@ -96,9 +97,11 @@ If CMD is deemed dangerous, ask for confirmation." (defmacro cj/defsystem-command (name var cmdstr &optional confirm) "Define VAR with CMDSTR and interactive command NAME to run it. -CONFIRM controls the confirmation prompt: t for a quick (Y/n) prompt, -the symbol `strong' for an explicit yes-or-no-p (used for irreversible -actions like shutdown and reboot), nil for no confirmation." +CONFIRM controls the confirmation prompt: t for a quick (Y/n) prompt where +RET and space mean yes, the symbol `strong' for `cj/confirm-destructive' +\(used for irreversible actions like shutdown and reboot), nil for no +confirmation. Both are one keystroke; the difference is that `strong' has +no default, so RET and space re-prompt rather than confirming." (declare (indent defun)) `(progn (defvar ,var ,cmdstr) diff --git a/modules/system-defaults.el b/modules/system-defaults.el index 9b4652e8..47bd1505 100644 --- a/modules/system-defaults.el +++ b/modules/system-defaults.el @@ -89,6 +89,30 @@ indicate the warning was handled." (advice-add 'display-warning :before-until #'cj/log-comp-warning) +;; ------------------ Deferred Daemon Warnings vs. Frame Creation ----------------- + +;; Emacs 31's warnings.el defers warnings raised during daemon startup: it puts +;; a one-shot closure on `after-make-frame-functions' holding the *Warnings* +;; buffer object and calls `warning--display-buffer' on it when the first +;; client frame is made. If that buffer died in between, `display-buffer' +;; signals inside `make-frame', server.el reports "-window-system-unsupported", +;; and emacsclient retries on $DISPLAY -- the first frame of the session +;; silently opens on XWayland. Keeping *Warnings* alive is the root fix +;; (undead-buffers.el); this guard is the backstop, so no future buffer sweep +;; can break frame creation the same way. The function only exists from +;; Emacs 31; advising an undefined symbol is harmless and takes effect once +;; warnings.el defines it. + +(defun cj/warning--display-buffer-if-live (orig buffer) + "Call ORIG with BUFFER only when it names or is a live buffer. +Around advice for `warning--display-buffer'. BUFFER may be a buffer object +or a buffer name, like `display-buffer' accepts. Return nil when skipped." + (let ((buf (and buffer (get-buffer buffer)))) + (when (buffer-live-p buf) + (funcall orig buf)))) + +(advice-add 'warning--display-buffer :around #'cj/warning--display-buffer-if-live) + ;; ---------------------------------- Unicode ---------------------------------- (set-locale-environment "en_US.UTF-8") @@ -227,8 +251,9 @@ appears only once per session." (setq ad-redefinition-action 'accept) ;; silence warnings about advised functions getting redefined. (setq large-file-warning-threshold nil) ;; open files regardless of size (setq use-short-answers t) ;; single-key y/n for ordinary yes-or-no-p prompts - ;; (irreversible actions use `cj/confirm-strong', which - ;; forces a typed "yes" by binding this nil for that call) + ;; (irreversible actions use `cj/confirm-destructive', + ;; also one key, but it ignores RET and space so a stray + ;; keystroke re-prompts instead of confirming) (setq auto-revert-verbose nil) ;; turn off auto revert messages (setq custom-safe-themes t) ;; treat all themes as safe (stop asking) (setq server-client-instructions nil) ;; I already know what to do when done with the frame diff --git a/modules/system-lib.el b/modules/system-lib.el index 54e20b74..c6021c9c 100644 --- a/modules/system-lib.el +++ b/modules/system-lib.el @@ -8,7 +8,8 @@ ;; Eager reason: low-level helpers (executable lookup, process output, silent ;; logging) used by many eager modules during startup. ;; Top-level side effects: none. -;; Runtime requires: none (auth-source loaded on demand inside the helper). +;; Runtime requires: none at load (auth-source is required on demand inside +;; `cj/auth-source-secret-value', so the cost lands only on callers that use it). ;; Direct test load: yes (pure helpers; batch-safe). ;; ;; This module provides low-level system utility functions for checking @@ -125,21 +126,51 @@ This does so without echoing in the minibuffer." With USER, also match on the login. Resolves a function-valued secret \(the netrc backend returns the secret as a function\) by calling it. Callers that must have a secret layer their own error on top." + ;; Loaded here rather than at the top of the file, so a module that merely + ;; requires system-lib does not pay for auth-source. It has to be loaded + ;; *somewhere*, though: `declare-function' only quiets the byte-compiler. + ;; An interactive Emacs always has auth-source in by the time anyone calls + ;; here, which hid the omission until a batch `-Q' sync tried to resolve a + ;; `:secret-host' feed and died on a void `auth-source-search'. + ;; + ;; Guarded on `fboundp' rather than calling `require' unconditionally: a + ;; bare require re-loads auth-source.el over whatever is already in place, + ;; which replaces a caller's stubbed `auth-source-search' mid-call and sends + ;; a test that meant to fake the lookup out to the real authinfo instead. + (unless (fboundp 'auth-source-search) + (require 'auth-source)) (let* ((spec (append (list :host host :require '(:secret) :max 1) (when user (list :user user)))) (secret (plist-get (car (apply #'auth-source-search spec)) :secret))) (if (functionp secret) (funcall secret) secret))) -;; ---------------------------- Strong Confirmation ---------------------------- +;; -------------------------- Destructive Confirmation ------------------------- -(defun cj/confirm-strong (prompt) - "Ask PROMPT, requiring a full typed \"yes\" or \"no\" answer. -For irreversible actions -- file destruction, overwrites, power-off. The -global default makes `yes-or-no-p' a single keystroke (`use-short-answers' -is t); this binds it to nil for the one call so the prompt demands the -long-form answer, keeping a stray RET or space from confirming." - (let ((use-short-answers nil)) - (yes-or-no-p prompt))) +(defun cj/confirm-destructive (prompt) + "Ask PROMPT for an irreversible action. Return non-nil for yes. + +One keystroke, y or n. Nothing else answers: a stray RET or space +re-prompts rather than confirming, so the accidental-confirm protection +survives without the answer costing four keystrokes. + +Pending input is discarded first, and that line is load-bearing. +`read-char-choice' reads from the input queue, so without it a keystroke +typed before the prompt appeared would confirm a shutdown or a file +deletion instantly. The typed-\"yes\" form this replaced absorbed such a +key harmlessly, and dropping the guard without replacing it would have +traded a rare annoyance for a rare catastrophe. + +This used to demand a typed \"yes\", and that was a worse trade than it +looked. On 2026-07-31 one such prompt went unanswered -- a second agent +session held the selected window while the prompt waited in another frame, +so keystrokes went to a terminal instead of the minibuffer, and the session +was killed with buffers unsaved. A single keystroke does not make a prompt +reachable when focus is elsewhere; C-g is still the escape either way. What +it changes is the cost of the situation, and losing unsaved buffers is a far +bigger hazard than a mis-keyed confirm." + (discard-input) + (eq ?y (downcase (read-char-choice (concat prompt "(y or n) ") + '(?y ?Y ?n ?N))))) (defun cj/--font-lock-global-modes-excluding (current mode) "Return CURRENT `font-lock-global-modes' with MODE added to the exclusion. diff --git a/modules/telega-config.el b/modules/telega-config.el index acc9e482..b9b80481 100644 --- a/modules/telega-config.el +++ b/modules/telega-config.el @@ -18,9 +18,10 @@ ;; ;; TDLib (Telegram Database Library) runs in a docker container via ;; `telega-use-docker' so a fresh-clone install does not need a -;; system-level TDLib build. =scripts/setup-telega.sh= prepares the -;; container the first time; afterwards telega.el reattaches -;; automatically. +;; system-level TDLib build. The image is built locally from +;; =docker/telega-server/Dockerfile= with =make telega-image= (see the +;; pin section below for why it is not pulled from the registry); +;; =scripts/setup-telega.sh= covers the rest of a fresh clone. ;; ;; First-run auth (phone number + Telegram verification code) is ;; interactive and happens inside `M-x telega'. This module does not @@ -48,6 +49,7 @@ ;;; Code: (require 'keybindings) +(require 'system-lib) ; cj/log-silently, used by the death alert (use-package telega :defer t @@ -63,6 +65,141 @@ ;; routing through a shared messenger notifier is the unification task. (telega-notifications-mode 1)) +;; --------------------------- telega Docker Image Pin ------------------------- +;; telega picks its container image in `telega-docker--image-name', which only +;; pins to a version tag when `telega-tdlib-min-version' equals +;; `telega-tdlib-max-version' and the version ends in ".0". Here min is +;; "1.8.66" and max is nil, so that test never passes and the image is always +;; "zevlg/telega-server:latest" -- a floating tag. The elpa package is fixed +;; at whatever version was installed, so the server can be replaced underneath +;; a static elisp without anything announcing it. +;; +;; The pin used to be a registry digest. It became a local tag on 2026-08-25: +;; the telega package raised its tdlib floor to 1.8.66, and upstream's only +;; image at that version fails to start (libglycin missing, +;; zevlg/telega.el#596). docker/telega-server/Dockerfile derives a working +;; image from that upstream digest plus the one missing package, and +;; `make telega-image' builds it under the tag below. The digest guarantee +;; now lives in the Dockerfile's FROM line; the Makefile owns the tag and a +;; test holds this default equal to it. Set to nil to hand the choice back +;; to telega. + +(defcustom cj/telega-docker-image + "cj/telega-server:1.8.66-glycin" + "Container image reference for `telega-server', or nil for telega's default. +The default names the image `make telega-image' builds locally from +docker/telega-server/Dockerfile, whose base is pinned by upstream digest. +It must match TELEGA_IMAGE in the Makefile; `cj/telega' refuses to launch +when the image is not present, since docker would otherwise try to pull a +local-only tag from the registry and fail confusingly." + :type '(choice (const :tag "Let telega infer the image" nil) + (string :tag "Image reference")) + :group 'telega-docker) + +(defun cj/--telega-docker-pinned-image () + "Return the configured image pin, or nil when none is usable. +A blank or non-string setting yields nil rather than reaching the docker +command line, where it would fail in a way that looks unrelated to this." + (when (stringp cj/telega-docker-image) + (let ((pin (string-trim cj/telega-docker-image))) + (unless (string-empty-p pin) pin)))) + +(defun cj/--telega-docker-image-name (orig-fun &rest args) + "Return the pinned telega-server image, else call ORIG-FUN with ARGS. +`:around' advice on `telega-docker--image-name', so clearing the pin +restores telega's own inference instead of breaking the image name." + (or (cj/--telega-docker-pinned-image) + (apply orig-fun args))) + +(with-eval-after-load 'telega-util + (advice-add 'telega-docker--image-name :around #'cj/--telega-docker-image-name)) + +;; ------------------------- telega-server Death Alert ------------------------- +;; telega's own sentinel reports an abnormal server exit with `message', which +;; scrolls out of the echo area unseen. That is how a dead server reads as a +;; quiet Telegram: the scan stops partway and the unscanned chats look like +;; chats with nothing in them. It has happened twice (2026-07-10, 2026-07-27), +;; caught both times only because something downstream noticed. A desktop +;; notification makes the death itself visible. + +(declare-function notifications-notify "notifications") + +(defun cj/--telega-server-death-p (status) + "Return non-nil when exit STATUS means the server died abnormally. +Any non-zero integer counts, which covers both a non-zero exit code and a +fatal signal number (`process-exit-status' reports SIGSEGV as 11). A +non-integer STATUS returns nil rather than signalling: this runs inside +telega's sentinel, where an error would abort telega's own cleanup." + (and (integerp status) + (not (zerop status)))) + +(defun cj/--telega-server-exit-status (proc) + "Return PROC's exit status, or nil when it can't be determined. +Guarded because the sentinel hands over whatever process object it has, +and a bad one must not break telega's status handling." + (condition-case nil + (and (processp proc) (process-exit-status proc)) + (error nil))) + +(defun cj/--telega-server-death-body (status event) + "Build the notification body for a server death with STATUS and EVENT. +EVENT is the sentinel's event string, which carries a trailing newline that +would render as dead space in a desktop notification." + (let ((detail (string-trim (or event "")))) + (concat (format "telega-server died (status %s). " status) + (unless (string-empty-p detail) (concat detail ". ")) + "Telegram coverage is down until it restarts."))) + +(defun cj/--telega-server-send-notification (title body) + "Deliver a desktop notification with TITLE and BODY. +Prefers the external notify script (persistent, so it waits rather than +auto-dismissing while away), falling back to `notifications-notify'. +Mirrors `cj/slack--send-notification'." + (let ((script (executable-find "notify"))) + (if script + (start-process "telega-death-notify" nil script "fail" title body "--persist") + (unless (fboundp 'notifications-notify) + (require 'notifications)) + (notifications-notify :title title :body body)))) + +(defun cj/--telega-server-notify-death (proc event) + "Notify when the telega-server PROC dies abnormally. EVENT is its event string. +Installed as `:after' advice on `telega-server--sentinel'. Silent on a +clean exit, so quitting telega deliberately never pages. + +The whole body is guarded: a notifier failure here would otherwise escape +into telega's sentinel and abort its status handling and relogin path." + (condition-case err + (let ((status (cj/--telega-server-exit-status proc))) + (when (cj/--telega-server-death-p status) + (cj/--telega-server-send-notification + "Telegram: telega-server died" + (cj/--telega-server-death-body status event)))) + (error + (cj/log-silently + (format "telega death notify failed: %s" (error-message-string err)))))) + +;; Named, never a lambda: anonymous advice can't be `advice-remove'd by +;; reference, so a live daemon keeps running it after the source stops +;; installing it. +(with-eval-after-load 'telega-server + (advice-add 'telega-server--sentinel :after #'cj/--telega-server-notify-death)) + +(defun cj/--telega-docker-image-present-p (image) + "Return non-nil when IMAGE exists in the local docker image store. +Uses `docker image inspect' rather than `docker images': the listing hides +digest-pulled and untagged images, and this check exists because that +listing lied once. Any failure (docker absent, daemon down) reads as +not-present, which routes the user to the same make target." + (condition-case nil + (zerop (call-process "docker" nil nil nil "image" "inspect" image)) + (error nil))) + +(defun cj/--telega-missing-image-message (image) + "Return the user-facing message for a pinned IMAGE that is not built yet." + (format "telega-server image %s is not built -- run `make telega-image' in %s" + image (abbreviate-file-name user-emacs-directory))) + (defun cj/telega () "Launch telega.el with a helpful message when it isn't installed yet. @@ -71,14 +208,22 @@ stale MELPA archive index can't take startup down with a 404. The trade-off: a fresh clone needs a one-time install before this launcher works. Without this wrapper, the autoload stub fails with the cryptic =Cannot open load file: telega=; with it, the user gets -pointed at =scripts/setup-telega.sh= and the manual fallback." +pointed at =scripts/setup-telega.sh= and the manual fallback. + +When `cj/telega-docker-image' is set, the image must already be built: +it is a local tag, so a missing one would send docker to the registry +for something that was never there. The check is skipped with no pin, +where telega infers and pulls its own image." (interactive) - (if (or (featurep 'telega) - (locate-library "telega")) - (telega) + (unless (or (featurep 'telega) + (locate-library "telega")) (user-error (concat "telega not installed -- run scripts/setup-telega.sh, " - "or `M-x package-install RET telega'")))) + "or `M-x package-install RET telega'"))) + (let ((image (cj/--telega-docker-pinned-image))) + (when (and image (not (cj/--telega-docker-image-present-p image))) + (user-error "%s" (cj/--telega-missing-image-message image)))) + (telega)) (cj/register-command "T" #'cj/telega) diff --git a/modules/undead-buffers.el b/modules/undead-buffers.el index e5b8dc00..e6574a0e 100644 --- a/modules/undead-buffers.el +++ b/modules/undead-buffers.el @@ -31,7 +31,25 @@ (defvar cj/undead-buffer-list '("*scratch*" "*EMMS-Playlist*" "*Messages*" "*ert*" - "*AI-Assistant*") + "*AI-Assistant*" + ;; *Warnings* stays alive because Emacs 31's warnings.el defers daemon + ;; startup warnings into an `after-make-frame-functions' closure that + ;; holds this buffer object until the first client frame. The startup + ;; sweep in `cj/dashboard-only' used to kill it; the closure then failed + ;; inside `make-frame', server.el reported the window system as + ;; unsupported, and emacsclient silently retried on $DISPLAY, so the first + ;; frame of every 31.1 session opened on XWayland. I bury it instead, the + ;; same choice desktop.el makes in `desktop-clear-preserve-buffers'. + "*Warnings*" + ;; The async native-compile log stays alive for the same reason, one + ;; buffer over. comp-run parks every compile worker on this buffer and + ;; the worker's sentinel reads it back before starting the next job. + ;; The startup sweep killed it, which SIGHUPs every :noquery worker under + ;; it; each sentinel then died in `with-current-buffer' on the dead + ;; buffer and `comp--run-async-workers' never ran again, so the queue + ;; sat stranded for the life of the daemon, nothing was ever cached, and + ;; every boot re-ran the same compile storm at the first frame. + "*Async-native-compile-log*") "Buffer names to bury instead of killing (exact match).") (defvar cj/undead-buffer-regexps nil diff --git a/modules/user-constants.el b/modules/user-constants.el index 570b142f..ec387930 100644 --- a/modules/user-constants.el +++ b/modules/user-constants.el @@ -275,5 +275,23 @@ and portable across different machines." ;; bare `(require 'user-constants)' (tests, byte-compile, batch) stays ;; side-effect-free. +(defconst cj/org-todo-keywords + '((sequence "TODO(t)" "PROJECT(p)" "DOING(i)" + "WAITING(w)" "VERIFY(v)" "STALLED(s)" + "DELEGATED(x)" "|" + "FAILED(f!)" "DONE(d!)" "CANCELLED(c!)")) + "The TODO keyword sequence, kept where a batch Emacs can reach it. + +`org-config' sets `org-todo-keywords' from this, and so does any batch process +that has to read the org files the way the editor does. It lives here rather +than in `org-config' because that module loads through `use-package' and needs +packages a batch run has no reason to install. + +The duplication this avoids is not cosmetic. A reader that does not know +DOING is a keyword does not merely mislabel it: org stops parsing the headline +as a task at all, so the keyword and the priority cookie stay glued to the +front of the title and the entry reads as not-done regardless of its real +state.") + (provide 'user-constants) ;;; user-constants.el ends here diff --git a/modules/video-audio-recording.el b/modules/video-audio-recording.el index 10c10854..65a8612f 100644 --- a/modules/video-audio-recording.el +++ b/modules/video-audio-recording.el @@ -300,6 +300,41 @@ Changes take effect on the next recording (not the current one)." (cj/register-prefix-map "r" cj/record-map) +;; Fast chords for the two toggles, alongside C-; r v and C-; r a. F9 is free: +;; ai-term vacated the F9 family when its swap moved to M-SPC, and +;; `test-ai-term-f9-family-removed-globally' keeps it vacated. Both commands +;; still take a prefix argument, so C-u F9 prompts for the recording location. +(keymap-global-set "<f9>" #'cj/video-recording-toggle) +(keymap-global-set "S-<f9>" #'cj/audio-recording-toggle) + +(defvar eat-mode-map) +(defvar eat-semi-char-mode-map) +(defvar eat-char-mode-map) +(defvar eat-eshell-char-mode-map) + +;; EAT builds each input mode's keymap from key categories, and which categories +;; a mode claims is what decides whether a chord reaches Emacs at all. +;; +;; Semi-char mode -- the default, and where every agent buffer sits -- is built +;; from :ascii, :arrow and :navigation. It never claims function keys, so F9 +;; already fell through to the global map. The semi-char entry below is +;; belt-and-braces rather than the fix, which is why it reads as redundant. +;; +;; Char mode is the one that swallows F9. It adds :function, binding f1 through +;; f63 to eat-self-input, and it is a minor mode, so its map outranks +;; eat-mode-map. Without an entry here the pair splits in the worst possible +;; way: :function claims only the unmodified keys, so S-F9 would toggle audio in +;; a char-mode buffer while F9 went to the program under the cursor. That is a +;; recording you believe you started and didn't. +;; +;; Claiming both costs a char-mode program the use of F9. I would rather pay +;; that than ship a toggle that works for audio and silently fails for video. +(with-eval-after-load 'eat + (dolist (map (list eat-semi-char-mode-map eat-mode-map + eat-char-mode-map eat-eshell-char-mode-map)) + (keymap-set map "<f9>" #'cj/video-recording-toggle) + (keymap-set map "S-<f9>" #'cj/audio-recording-toggle))) + (with-eval-after-load 'which-key (which-key-add-key-based-replacements "C-; r" "recording menu" diff --git a/modules/weather-config.el b/modules/weather-config.el index 84920776..ea137578 100644 --- a/modules/weather-config.el +++ b/modules/weather-config.el @@ -28,6 +28,13 @@ ;; :vc (:url "git@cjennings.net:emacs-wttrin.git" ;; :branch "release/0.4.0" ;; :rev :newest) + ;; wttrin declares xterm-color in its own Package-Requires, but nothing here + ;; reads that header: `:load-path' keeps package.el out of the picture, and + ;; use-package suppresses the `use-package-always-ensure' default whenever + ;; `:load-path' is present. The dependency came free under the `:vc' form + ;; above and stopped when the local checkout took over. Naming the package + ;; here installs it without disturbing the checkout. + :ensure xterm-color :demand t ;; REQUIRED: mode-line must start at Emacs startup :preface ;; Change this to t to enable debug logging diff --git a/scripts/agenda-render-cache b/scripts/agenda-render-cache new file mode 100755 index 00000000..b1e4d490 --- /dev/null +++ b/scripts/agenda-render-cache @@ -0,0 +1,50 @@ +#!/usr/bin/env bash +# Write the agenda render cache for an external renderer. +# +# Runs a batch Emacs rather than talking to the daemon, because the surface +# that reads the cache has to keep working while Emacs is down -- and +# emacsclient is exactly the thing that cannot. Nothing here touches a running +# Emacs, so it is safe to fire from a timer alongside an active session. +# +# The agenda file list is resolved the same way the editor resolves it, by +# loading the config's own resolver rather than restating the list here. A +# second copy of that list would drift the first time a calendar source is +# added. +# +# Usage: agenda-render-cache +# Env: EMACS_D -- config directory (default ~/.emacs.d) +# EMACS -- emacs binary (default emacs) +# AGENDA_RENDER_FILES -- colon-separated org files to read instead of +# the configured agenda list. Lets a caller ask +# about a known set, and lets the tests run +# against a fixture rather than whatever happens +# to be on the machine's real agenda today. + +set -euo pipefail + +EMACS_D="${EMACS_D:-$HOME/.emacs.d}" +EMACS="${EMACS:-emacs}" + +if [ ! -d "$EMACS_D/modules" ]; then + echo "agenda-render-cache: no modules directory at $EMACS_D/modules" >&2 + exit 1 +fi + +# -Q keeps the daemon's init out of it: this needs three modules, not a full +# editor. load-prefer-newer stops a stale .elc from answering for changed +# source, which would silently write yesterday's logic. +exec "$EMACS" --batch -Q \ + --eval '(setq load-prefer-newer t)' \ + -L "$EMACS_D/modules" \ + --eval '(progn + (require (quote user-constants)) + (require (quote org-agenda-config)) + (setq org-todo-keywords cj/org-todo-keywords) + (require (quote agenda-query)) + (setq org-agenda-files + (let ((override (getenv "AGENDA_RENDER_FILES"))) + (if (and override (not (string-empty-p override))) + (split-string override ":" t) + (cj/--org-agenda-scan-files)))) + (princ (cj/agenda-render-cache-update)) + (terpri))' diff --git a/scripts/bootstrap-packages.sh b/scripts/bootstrap-packages.sh new file mode 100755 index 00000000..9ba9fc69 --- /dev/null +++ b/scripts/bootstrap-packages.sh @@ -0,0 +1,133 @@ +#!/usr/bin/env bash +# +# Install every package this config asks for, headlessly, before first launch. +# +# On a fresh machine init.el pulls ~190 packages over the network one at a +# time. A single dead download used to abort startup outright; +# modules/package-resilience.el now records the failure and lets init finish, +# and this script is what turns that into a completed install: load init.el in +# batch, retry whatever is still missing, and repeat while progress is being +# made. Doing it here rather than in a GUI session means a fresh install never +# meets the debugger. +# +# Usage: scripts/bootstrap-packages.sh +# Exit: 0 when every package is installed, non-zero otherwise. +# +# Environment: +# EMACS emacs binary to use (default: emacs) +# BOOTSTRAP_PASSES maximum passes over the set (default: 4) +# BOOTSTRAP_TIMEOUT seconds allowed per pass (default: 1800) +# +# Note: a pass loads the whole config in batch, so every :config block runs +# headlessly. stdin is closed and each pass is bounded by a timeout so a +# prompt or a hung network fetch fails the pass instead of stalling forever. + +set -uo pipefail + +emacs_bin="${EMACS:-emacs}" +max_passes="${BOOTSTRAP_PASSES:-4}" +pass_timeout="${BOOTSTRAP_TIMEOUT:-1800}" + +emacs_dir="${BOOTSTRAP_DIR:-$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)}" +log_dir="$(mktemp -d -t emacs-bootstrap-XXXXXX)" + +cleanup() { rm -rf "$log_dir"; } +trap cleanup EXIT + +# --batch implies -q, which skips early-init.el. That file is where the package +# archives, use-package-always-ensure, and package-resilience all live, so a +# pass that loaded only init.el would install almost nothing and would not even +# have cj/package-bootstrap-batch defined. Load both, in the order a real +# startup does. user-emacs-directory is set first so the pass bootstraps the +# checkout this script lives in rather than whatever $HOME/.emacs.d happens to +# be. +load_form="$(cat <<EOF +(progn + (setq load-prefer-newer t) + (setq user-emacs-directory "${emacs_dir}/") + (setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) + (load (expand-file-name "early-init.el" user-emacs-directory) nil t) + (load (expand-file-name "init.el" user-emacs-directory) nil t) + (cj/package-bootstrap-batch)) +EOF +)" + +echo "bootstrap: installing packages for $emacs_dir" +echo "bootstrap: up to $max_passes passes, ${pass_timeout}s each" + +# use-package calls its ensure function at macro-expansion time when a file is +# being byte-compiled, and emits no runtime call at all. So a pass that loads +# .elc files installs nothing and would still exit 0 -- a false pass, the same +# shape as every other gate in this repo that was green because it never ran. +# Refuse rather than warn: there is no use for a bootstrap that cannot install, +# and a warning above a success line is read as a success. A genuinely fresh +# machine has no .elc and never sees this. +# Every directory the config puts on its load-path, not just modules/, since a +# use-package form anywhere in them would be consumed the same way. +if compgen -G "$emacs_dir/modules/*.elc" >/dev/null 2>&1 \ + || compgen -G "$emacs_dir/custom/*.elc" >/dev/null 2>&1 \ + || compgen -G "$emacs_dir/assets/*.elc" >/dev/null 2>&1 \ + || compgen -G "$emacs_dir/*.elc" >/dev/null 2>&1; then + echo "bootstrap: REFUSING - byte-compiled modules are present." >&2 + echo "bootstrap: use-package consumes :ensure at compile time, so a pass over" >&2 + echo "bootstrap: .elc files installs nothing and would report success anyway." >&2 + echo "bootstrap: run 'make clean-compiled' first, then bootstrap." >&2 + exit 2 +fi + +pass=1 +passes_run=0 +status=1 +while [ "$pass" -le "$max_passes" ]; do + log="$log_dir/pass-$pass.log" + echo "bootstrap: pass $pass of $max_passes ..." + + timeout "$pass_timeout" "$emacs_bin" --batch \ + --eval "$load_form" </dev/null >"$log" 2>&1 + status=$? + passes_run=$((passes_run + 1)) + + case "$status" in + 0) + echo "bootstrap: every package is installed (pass $pass)" + break + ;; + 1) + # Exit 1 is only meaningful when the pass actually said what is + # missing. Anything else exiting 1 is a different failure, and + # retrying it four times then blaming packages would be a lie. + if grep -E '^package-bootstrap: [0-9]+ missing:' "$log"; then + : # another pass can clear them; installing one unblocks others + else + echo "bootstrap: pass $pass exited 1 without reporting missing packages" >&2 + tail -30 "$log" >&2 + break + fi + ;; + 124) + echo "bootstrap: pass $pass hit the ${pass_timeout}s timeout" >&2 + tail -20 "$log" >&2 + ;; + *) + # init itself failed for some reason other than a missing package. + echo "bootstrap: pass $pass failed to load init (exit $status)" >&2 + tail -30 "$log" >&2 + break + ;; + esac + + pass=$((pass + 1)) +done + +if [ "$status" -ne 0 ]; then + echo "bootstrap: FAILED after $passes_run pass(es)" >&2 + # No pass ran at all when the ceiling is zero, and the glob would then match + # nothing and print a tail error over the real message. + if [ "$passes_run" -gt 0 ]; then + echo "bootstrap: tail of the last pass follows" >&2 + tail -30 "$log" >&2 + fi + exit "$status" +fi + +exit 0 diff --git a/scripts/calendar-sync-run b/scripts/calendar-sync-run new file mode 100755 index 00000000..12181b8d --- /dev/null +++ b/scripts/calendar-sync-run @@ -0,0 +1,63 @@ +#!/usr/bin/env bash +# Sync every configured calendar from its .ics feed, once, and wait for it. +# +# Runs a batch Emacs rather than talking to the daemon, for the same reason +# agenda-render-cache does: the org files this writes feed the agenda, waybar +# and the projected wallpaper, and none of those should go stale because the +# editor happens to be down. Nothing here touches a running Emacs, so it is +# safe to fire from a timer alongside an active session. +# +# Why a script at all: calendar-sync used to start its hourly timer from +# `org-agenda-mode-hook', so a session where the agenda was never opened never +# synced at all. That is not a rare corner -- it is every reboot until the +# first agenda call. The timer owns the schedule now, and the editor's own +# auto-start is off. +# +# The exit code is the point. `calendar-sync-batch-run-and-report' waits for +# every calendar to leave the syncing state and returns non-zero if any did +# not land, so a failed fetch shows up in `systemctl --user status' instead of +# being swallowed. +# +# Usage: calendar-sync-run +# Env: EMACS_D -- config directory (default ~/.emacs.d) +# EMACS -- emacs binary (default emacs) +# CALENDAR_SYNC_CONFIG -- private config file holding the calendar +# list, instead of the configured default. +# CALENDAR_SYNC_STATE -- sync-state file, instead of the configured +# default. Lets a test run without writing +# the real session's persisted state. +# CALENDAR_SYNC_TIMEOUT -- seconds to wait for all calendars to settle. + +set -euo pipefail + +EMACS_D="${EMACS_D:-$HOME/.emacs.d}" +EMACS="${EMACS:-emacs}" + +if [ ! -d "$EMACS_D/modules" ]; then + echo "calendar-sync-run: no modules directory at $EMACS_D/modules" >&2 + exit 1 +fi + +# The overrides are set before the module loads on purpose: the private config +# is read at load time, and `defvar'/`defcustom' both leave an already-bound +# value alone. This is the same seam the in-editor conversion worker uses. +pre="" +if [ -n "${CALENDAR_SYNC_CONFIG:-}" ]; then + pre="$pre (setq calendar-sync-private-config-file \"$CALENDAR_SYNC_CONFIG\")" +fi +if [ -n "${CALENDAR_SYNC_STATE:-}" ]; then + pre="$pre (setq calendar-sync--state-file \"$CALENDAR_SYNC_STATE\")" +fi +if [ -n "${CALENDAR_SYNC_TIMEOUT:-}" ]; then + pre="$pre (setq calendar-sync-batch-timeout $CALENDAR_SYNC_TIMEOUT)" +fi + +# -Q keeps the daemon's init out of it: this needs the calendar-sync modules, +# not a full editor. load-prefer-newer stops a stale .elc from answering for +# changed source, which would silently sync with yesterday's logic. +exec "$EMACS" --batch -Q \ + --eval "(progn (setq load-prefer-newer t)$pre)" \ + -L "$EMACS_D/modules" \ + --eval '(progn + (require (quote calendar-sync)) + (kill-emacs (calendar-sync-batch-run-and-report)))' diff --git a/scripts/setup-telega.sh b/scripts/setup-telega.sh index 9a8c0d02..351f98ba 100755 --- a/scripts/setup-telega.sh +++ b/scripts/setup-telega.sh @@ -7,8 +7,8 @@ # - Verifies docker is installed and the daemon is responsive. # - Verifies the user can talk to docker without sudo (group membership). # - Pulls the telega-server image if a public one is configured (env var -# `TELEGA_DOCKER_IMAGE'); otherwise prints the in-Emacs build command -# (`M-x telega-server-build') for the user to run once. +# `TELEGA_DOCKER_IMAGE'); otherwise points at `make telega-image', which +# builds the pinned image from docker/telega-server/Dockerfile. # - Installs the `telega' Emacs package via package.el if it isn't # already in package-user-dir. modules/telega-config.el uses # `:ensure nil' (a stale MELPA index can 404 and take startup down @@ -52,10 +52,10 @@ pull_or_announce_image() { if [[ -z "$TELEGA_DOCKER_IMAGE" ]]; then cat <<EOF → no public image configured (set TELEGA_DOCKER_IMAGE to override) - build the telega-server image once from inside Emacs: - M-x telega-server-build - telega.el handles the docker build under the hood when - \`telega-use-docker' is t (set in modules/telega-config.el). + build the telega-server image once from the repo's Dockerfile: + make telega-image + modules/telega-config.el pins \`cj/telega-docker-image' to the tag + that target builds (docker/telega-server/Dockerfile). EOF return 0 fi diff --git a/systemd/agenda-render-cache.service b/systemd/agenda-render-cache.service new file mode 100644 index 00000000..0fe08533 --- /dev/null +++ b/systemd/agenda-render-cache.service @@ -0,0 +1,14 @@ +[Unit] +Description=Write the agenda render cache for external surfaces +# Deliberately no dependency on emacs.service or graphical-session.target. +# The whole point is that the cache stays current while Emacs is down, so the +# writer is a batch Emacs that needs neither the daemon nor a compositor. +Documentation=file:%h/.emacs.d/modules/agenda-query.el + +[Service] +Type=oneshot +ExecStart=%h/.emacs.d/scripts/agenda-render-cache +# One run is about a second of CPU. Cap it well above that so a wedged run is +# killed rather than left holding the timer. +TimeoutStartSec=120 +Nice=10 diff --git a/systemd/agenda-render-cache.timer b/systemd/agenda-render-cache.timer new file mode 100644 index 00000000..71a6d662 --- /dev/null +++ b/systemd/agenda-render-cache.timer @@ -0,0 +1,17 @@ +[Unit] +Description=Refresh the agenda render cache every 5 minutes + +[Timer] +# OnCalendar rather than OnUnitActiveSec, because Persistent= only has an +# effect on calendar timers (systemd.timer(5)). A monotonic schedule silently +# ignores it, so a machine that slept through several intervals would come back +# to a stale file with nothing to trigger a catch-up -- and the surface reading +# it cannot tell stale from correct. +OnCalendar=*:0/5 +Persistent=true +# A cold boot should not wait for the next wall-clock slot. +OnBootSec=1min +AccuracySec=30s + +[Install] +WantedBy=timers.target diff --git a/systemd/calendar-sync.service b/systemd/calendar-sync.service new file mode 100644 index 00000000..0d70de57 --- /dev/null +++ b/systemd/calendar-sync.service @@ -0,0 +1,17 @@ +[Unit] +Description=Sync calendars from their .ics feeds into org +# Deliberately no dependency on emacs.service or graphical-session.target. +# The point of moving this out of the editor is that calendars stay current +# while Emacs is down, so the writer is a batch Emacs that needs neither the +# daemon nor a compositor. +Documentation=file:%h/.emacs.d/modules/calendar-sync.el + +[Service] +Type=oneshot +ExecStart=%h/.emacs.d/scripts/calendar-sync-run +# The script waits for every calendar to settle, bounded by +# calendar-sync-batch-timeout (300s). Cap the unit above that so the script's +# own timeout reports a named failure per calendar, rather than systemd +# killing it first and leaving only "timeout". +TimeoutStartSec=360 +Nice=10 diff --git a/systemd/calendar-sync.timer b/systemd/calendar-sync.timer new file mode 100644 index 00000000..71278f20 --- /dev/null +++ b/systemd/calendar-sync.timer @@ -0,0 +1,18 @@ +[Unit] +Description=Sync calendars into org every 10 minutes + +[Timer] +# OnCalendar rather than OnUnitActiveSec, because Persistent= only has an +# effect on calendar timers (systemd.timer(5)). A monotonic schedule silently +# ignores it, so a machine that slept through several intervals would come +# back to stale calendar files with nothing to trigger a catch-up. +OnCalendar=*:0/10 +Persistent=true +# A cold boot should not wait for the next wall-clock slot. This is the case +# the whole change exists for: before the timer, a reboot meant no calendar +# sync at all until the agenda happened to be opened. +OnBootSec=2min +AccuracySec=30s + +[Install] +WantedBy=timers.target diff --git a/tests/test-agenda-query--bounds.el b/tests/test-agenda-query--bounds.el new file mode 100644 index 00000000..9ee423e7 --- /dev/null +++ b/tests/test-agenda-query--bounds.el @@ -0,0 +1,169 @@ +;;; test-agenda-query--bounds.el --- Tests for timestamp bounds -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/--agenda-query-timestamp-bounds', which turns an org-element +;; timestamp into epoch bounds for the JSON query. +;; +;; The contract under test: +;; - :start is the epoch of the timestamp's start. +;; - :end is the epoch of an explicit range end, or nil when the source has no +;; range. A null end is information the consumer cannot re-derive, so it is +;; never filled in with a guess. +;; - :all-day is t when the timestamp carries no hour. +;; - :effective-end is what the window predicate uses: the explicit end, or for +;; an all-day entry the end of its last day, or for a timed point event the +;; start itself. This is the "treat the day as its extent" rule, kept out of +;; :end so the reported shape stays faithful to the source. +;; +;; Helpers carry a file-unique prefix on purpose: the editor hook loads every +;; agenda-query test file into ONE process, so a shared helper name here would +;; silently redefine its namesake in a sibling file. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) + +(defun test-aq-bounds--epoch (sec min hour day month year) + "Return the epoch second for the local time SEC MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list sec min hour day month year nil -1 nil)) + 'integer)) + +(defun test-aq-bounds--of (raw) + "Parse timestamp string RAW and return its bounds plist." + (cj/--agenda-query-timestamp-bounds (org-timestamp-from-string raw))) + +;;; Normal Cases + +(ert-deftest test-agenda-query-bounds-normal-timed-range () + "Normal: a same-day timed range reports both ends and is not all-day." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 23:00-23:30>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 23 31 7 2026))) + (should (equal (plist-get b :end) + (test-aq-bounds--epoch 0 30 23 31 7 2026))) + (should-not (plist-get b :all-day)) + (should (equal (plist-get b :effective-end) (plist-get b :end))))) + +(ert-deftest test-agenda-query-bounds-normal-timed-point () + "Normal: a timed point event has no end, and its extent is the instant." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 14:00>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 14 31 7 2026))) + (should-not (plist-get b :end)) + (should-not (plist-get b :all-day)) + (should (equal (plist-get b :effective-end) (plist-get b :start))))) + +;;; Boundary Cases + +(ert-deftest test-agenda-query-bounds-boundary-all-day-extent () + "Boundary: an all-day entry reports no end but extends over its whole day." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 31 7 2026))) + (should-not (plist-get b :end)) + (should (plist-get b :all-day)) + ;; One second short of the next midnight -- the day is the extent. + (should (equal (plist-get b :effective-end) + (1- (test-aq-bounds--epoch 0 0 0 1 8 2026)))))) + +(ert-deftest test-agenda-query-bounds-boundary-multi-day-all-day () + "Boundary: a multi-day all-day range ends at the close of its last day." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri>--<2026-08-02 Sun>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 31 7 2026))) + (should (plist-get b :all-day)) + (should (equal (plist-get b :end) + (1- (test-aq-bounds--epoch 0 0 0 3 8 2026)))) + (should (equal (plist-get b :effective-end) (plist-get b :end))))) + +(ert-deftest test-agenda-query-bounds-boundary-midnight-start () + "Boundary: an explicit 00:00 is a timed event, not an all-day one." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 00:00>"))) + (should-not (plist-get b :all-day)) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 31 7 2026))))) + +(ert-deftest test-agenda-query-bounds-boundary-dst-spring-forward () + "Boundary: a timestamp on a DST changeover day still resolves to one epoch. +US DST began 2026-03-08. The interface is epoch seconds precisely so the +consumer never has to know the source timestamps are naive local time." + (let ((b (test-aq-bounds--of "<2026-03-08 Sun 13:00>"))) + (should (integerp (plist-get b :start))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 13 8 3 2026))))) + +(ert-deftest test-agenda-query-bounds-boundary-dst-day-is-23-hours () + "Boundary: the day-extent rule follows real clock time, not a fixed 86400. +2026-03-08 loses an hour, so its all-day extent is one second short of 23 +hours. Adding a constant day would overshoot into the next day." + (let ((b (test-aq-bounds--of "<2026-03-08 Sun>"))) + (should (equal (plist-get b :effective-end) + (1- (test-aq-bounds--epoch 0 0 0 9 3 2026)))) + (should (= (- (plist-get b :effective-end) (plist-get b :start)) + (1- (* 23 3600)))))) + +(ert-deftest test-agenda-query-bounds-boundary-same-day-range-crosses-midnight () + "Boundary: a range whose end precedes its start is read as crossing midnight. + +Org records <2026-07-31 Fri 23:00-01:00> with day-end EQUAL to day-start, so +reading it literally puts the end 22 hours before the start. A negative +duration is meaningless to a renderer, and the row would also vanish from the +very window it belongs to, since its effective end would sit before the +window opens." + (let ((b (test-aq-bounds--of "<2026-07-31 Fri 23:00-01:00>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 23 31 7 2026))) + (should (equal (plist-get b :end) + (test-aq-bounds--epoch 0 0 1 1 8 2026))) + (should (> (plist-get b :end) (plist-get b :start))) + (should (= (- (plist-get b :end) (plist-get b :start)) (* 2 3600))))) + +(ert-deftest test-agenda-query-bounds-boundary-reversed-multi-day-range () + "Boundary: a genuinely reversed multi-day range reports no end at all. + +The midnight roll is scoped to same-day ranges, which is the shape org uses +for <23:00-01:00>. Rolling a reversed multi-day range would shift a wrong +date by one day and leave it still wrong, so instead the entry is reported as +a point -- a consumer can draw that, where a negative-duration bar is +meaningless." + (let ((b (test-aq-bounds--of "<2026-08-02 Sun 09:00>--<2026-07-31 Fri 08:00>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 9 2 8 2026))) + (should-not (plist-get b :end)) + (should (equal (plist-get b :effective-end) (plist-get b :start))))) + +(ert-deftest test-agenda-query-bounds-boundary-reversed-all-day-range () + "Boundary: a reversed ALL-DAY range also reports no end. + +The same malformed shape as the timed case, and the same consequence if it +slips through: the negative extent would sit before the start, so the entry +would vanish from the very day it opens on. A typo or a bad ICS import +produces this." + (let ((b (test-aq-bounds--of "<2026-08-05 Wed>--<2026-08-01 Sat>"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 0 5 8 2026))) + (should-not (plist-get b :end)) + ;; Falls back to its own day, so it still appears on 5 August. + (should (> (plist-get b :effective-end) (plist-get b :start))))) + +;;; Error Cases + +(ert-deftest test-agenda-query-bounds-error-inactive-still-computes () + "Error: bounds are purely arithmetic -- filtering inactive stamps is a +separate concern, so an inactive timestamp still yields usable bounds." + (let ((b (test-aq-bounds--of "[2026-07-31 Fri 09:00]"))) + (should (equal (plist-get b :start) + (test-aq-bounds--epoch 0 0 9 31 7 2026))))) + +(ert-deftest test-agenda-query-bounds-error-nil-timestamp () + "Error: a nil timestamp yields nil rather than signaling." + (should-not (cj/--agenda-query-timestamp-bounds nil))) + +(provide 'test-agenda-query--bounds) +;;; test-agenda-query--bounds.el ends here diff --git a/tests/test-agenda-query--occurrences.el b/tests/test-agenda-query--occurrences.el new file mode 100644 index 00000000..4fa73a0c --- /dev/null +++ b/tests/test-agenda-query--occurrences.el @@ -0,0 +1,242 @@ +;;; test-agenda-query--occurrences.el --- Tests for window + repeats -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/--agenda-query-occurrences' and the repeater cookie helper. +;; +;; Two behaviors under test: +;; +;; 1. The window predicate is intersection, not containment. An event running +;; across the window's start edge is in the window -- on a live surface it is +;; the thing currently happening. +;; +;; 2. A repeating entry contributes one row per occurrence inside the window, +;; expanded through org's own arithmetic. The base timestamp of a long-lived +;; repeater sits far in the past, so returning it raw would put a task that is +;; genuinely due today outside the window entirely. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) + +(defun test-agenda-query-occ--epoch (min hour day month year) + "Return the epoch for local MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list 0 min hour day month year nil -1 nil)) + 'integer)) + +(defun test-agenda-query-occ--of (raw start end) + "Return occurrences of timestamp string RAW within START..END." + (cj/--agenda-query-occurrences (org-timestamp-from-string raw) start end)) + +(defun test-agenda-query-occ--starts (raw start end) + "Return just the start epochs of RAW's occurrences within START..END." + (mapcar #'car (test-agenda-query-occ--of raw start end))) + +;;; ---------- repeater cookie ---------- + +(ert-deftest test-agenda-query-cookie-normal-all-three-styles () + "Normal: each repeater style round-trips to its raw cookie." + (should (equal "+1d" (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed +1d>")))) + (should (equal "++2w" (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed ++2w>")))) + (should (equal ".+3m" (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed .+3m>"))))) + +(ert-deftest test-agenda-query-cookie-boundary-none () + "Boundary: a plain timestamp has no cookie, and nil is not a cookie." + (should-not (cj/--agenda-query-repeater-cookie + (org-timestamp-from-string "<2026-07-01 Wed>"))) + (should-not (cj/--agenda-query-repeater-cookie nil))) + +;;; ---------- window predicate ---------- + +(ert-deftest test-agenda-query-occ-normal-inside-window () + "Normal: an event wholly inside the window is returned once, with its end." + (let* ((win-start (test-agenda-query-occ--epoch 0 8 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 18 31 7 2026)) + (occ (test-agenda-query-occ--of "<2026-07-31 Fri 09:00-10:00>" + win-start win-end))) + (should (= 1 (length occ))) + (should (equal (caar occ) (test-agenda-query-occ--epoch 0 9 31 7 2026))) + (should (equal (cdar occ) (test-agenda-query-occ--epoch 0 10 31 7 2026))))) + +(ert-deftest test-agenda-query-occ-boundary-overlaps-start-edge () + "Boundary: an event that began before the window but is still running is in. +This is the 23:00-01:00 case -- the whole reason the predicate is intersects +rather than starts-inside." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 1 8 2026)) + (win-end (test-agenda-query-occ--epoch 0 23 1 8 2026))) + (should (= 1 (length (test-agenda-query-occ--of + "<2026-07-31 Fri 23:00>--<2026-08-01 Sat 01:00>" + win-start win-end)))))) + +(ert-deftest test-agenda-query-occ-boundary-touches-edge-exactly () + "Boundary: an event ending exactly at the window start is still included." + (let* ((win-start (test-agenda-query-occ--epoch 0 10 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 18 31 7 2026))) + (should (= 1 (length (test-agenda-query-occ--of + "<2026-07-31 Fri 09:00-10:00>" win-start win-end)))))) + +(ert-deftest test-agenda-query-occ-boundary-all-day-covers-window () + "Boundary: an all-day entry covers any window inside its day." + (let* ((win-start (test-agenda-query-occ--epoch 0 13 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 30 13 31 7 2026)) + (occ (test-agenda-query-occ--of "<2026-07-31 Fri>" win-start win-end))) + (should (= 1 (length occ))) + ;; No range in the source, so no end is invented. + (should-not (cdar occ)))) + +(ert-deftest test-agenda-query-occ-boundary-outside-window () + "Boundary: an event finishing before the window opens is excluded." + (let* ((win-start (test-agenda-query-occ--epoch 0 12 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 18 31 7 2026))) + (should-not (test-agenda-query-occ--of "<2026-07-31 Fri 09:00-10:00>" + win-start win-end)))) + +;;; ---------- repeat expansion ---------- + +(ert-deftest test-agenda-query-occ-normal-daily-repeat-reaches-today () + "Normal: a daily repeater based a month back yields today's occurrence. +Returning the raw base date would put a task genuinely due today far outside +the window -- this is the failure the expansion exists to prevent." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (starts (test-agenda-query-occ--starts "<2026-07-01 Wed 09:00 +1d>" + win-start win-end))) + (should (equal starts (list (test-agenda-query-occ--epoch 0 9 31 7 2026)))))) + +(ert-deftest test-agenda-query-occ-normal-repeat-preserves-duration () + "Normal: an expanded occurrence keeps the base timestamp's duration." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (occ (car (test-agenda-query-occ--of "<2026-07-01 Wed 09:00-10:30 +1d>" + win-start win-end)))) + (should occ) + (should (equal (car occ) (test-agenda-query-occ--epoch 0 9 31 7 2026))) + (should (equal (cdr occ) (test-agenda-query-occ--epoch 30 10 31 7 2026))))) + +(ert-deftest test-agenda-query-occ-boundary-one-row-per-occurrence () + "Boundary: a window wider than the interval yields a row per occurrence. +A count is derivable from rows; rows are not derivable from a count, so the +row form is what the query returns." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 27 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (starts (test-agenda-query-occ--starts "<2026-07-01 Wed 09:00 +1d>" + win-start win-end))) + (should (= 5 (length starts))) + (should (equal starts + (list (test-agenda-query-occ--epoch 0 9 27 7 2026) + (test-agenda-query-occ--epoch 0 9 28 7 2026) + (test-agenda-query-occ--epoch 0 9 29 7 2026) + (test-agenda-query-occ--epoch 0 9 30 7 2026) + (test-agenda-query-occ--epoch 0 9 31 7 2026)))))) + +(ert-deftest test-agenda-query-occ-boundary-weekly-lands-on-its-day () + "Boundary: a weekly repeater yields only the days it actually falls on. +2026-07-01 is a Wednesday, so within Mon 27 -- Fri 31 July only Wed 29 counts." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 27 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (starts (test-agenda-query-occ--starts "<2026-07-01 Wed 09:00 +1w>" + win-start win-end))) + (should (equal starts (list (test-agenda-query-occ--epoch 0 9 29 7 2026)))))) + +(ert-deftest test-agenda-query-occ-boundary-restart-style-expands () + "Boundary: a .+ repeater expands from its base like any other style. + +Org rewrites a restart repeater's base timestamp when the task is completed, +so for an open task the base IS the last repeat and base-relative expansion is +what the agenda shows. All three styles agree here." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026)) + (expected (list (test-agenda-query-occ--epoch 0 9 31 7 2026)))) + (dolist (raw '("<2026-07-01 Wed 09:00 +1d>" + "<2026-07-01 Wed 09:00 ++1d>" + "<2026-07-01 Wed 09:00 .+1d>")) + (should (equal expected + (test-agenda-query-occ--starts raw win-start win-end)))))) + +(ert-deftest test-agenda-query-occ-boundary-repeat-not-yet-started () + "Boundary: a repeater whose base is after the window yields nothing." + (let* ((win-start (test-agenda-query-occ--epoch 0 0 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 31 7 2026))) + (should-not (test-agenda-query-occ--starts "<2026-12-01 Tue 09:00 +1d>" + win-start win-end)))) + +(ert-deftest test-agenda-query-occ-boundary-zero-value-repeater () + "Boundary: org treats a zero-value repeater as void, so it behaves as a +plain timestamp -- absent when its base is outside the window, and present +exactly once when the base is inside it. + +Both halves are asserted deliberately. The absent half alone would also pass +against an implementation with no repeater support at all, which makes it no +evidence about zero-value handling." + (should-not (test-agenda-query-occ--starts + "<2026-07-01 Wed 09:00 +0d>" + (test-agenda-query-occ--epoch 0 0 31 7 2026) + (test-agenda-query-occ--epoch 59 23 31 7 2026))) + (should (equal (list (test-agenda-query-occ--epoch 0 9 1 7 2026)) + (test-agenda-query-occ--starts + "<2026-07-01 Wed 09:00 +0d>" + (test-agenda-query-occ--epoch 0 0 1 7 2026) + (test-agenda-query-occ--epoch 59 23 1 7 2026))))) + +(ert-deftest test-agenda-query-occ-boundary-repeat-in-progress-at-window-start () + "Boundary: a repeating event that began before the window and is still +running is returned. + +The non-repeating path honors intersects-not-contains; the repeating path has +to as well. Scanning only days inside the window misses this, because the +occurrence's own day starts earlier: a nightly 22:00-02:00 job is the thing +actually happening at 03:00, and a renderer that drops it shows an empty slot +during the event." + (let ((raw "<2026-07-01 Wed 22:00 +1d>--<2026-07-02 Thu 02:00>")) + (should (= 1 (length (test-agenda-query-occ--of + raw + (test-agenda-query-occ--epoch 0 0 31 7 2026) + (test-agenda-query-occ--epoch 0 6 31 7 2026))))) + ;; The same occurrence seen from inside its own evening. + (should (= 1 (length (test-agenda-query-occ--of + raw + (test-agenda-query-occ--epoch 0 21 31 7 2026) + (test-agenda-query-occ--epoch 0 23 31 7 2026))))))) + +(ert-deftest test-agenda-query-occ-boundary-repeat-extent-follows-dst () + "Boundary: an all-day repeat's extent is recomputed per occurrence day. + +US DST ends 2026-11-01, making that day 25 hours long. Carrying the base +day's length forward as a fixed number of seconds leaves the occurrence +ending an hour early, so a window late on that day sees nothing while the +identical non-repeating entry is found." + (let ((win-start (test-agenda-query-occ--epoch 30 23 1 11 2026)) + (win-end (test-agenda-query-occ--epoch 59 23 1 11 2026))) + (should (= 1 (length (test-agenda-query-occ--of "<2026-07-01 Wed +1d>" + win-start win-end)))) + ;; The non-repeating control: same day, same window, must agree. + (should (= 1 (length (test-agenda-query-occ--of "<2026-11-01 Sun>" + win-start win-end)))))) + +;;; ---------- error cases ---------- + +(ert-deftest test-agenda-query-occ-error-inverted-window () + "Error: a window whose start is after its end matches nothing. +Without the guard the intersection test passes for any long-running event, +which would silently return rows for a nonsense request." + (let* ((win-start (test-agenda-query-occ--epoch 0 18 31 7 2026)) + (win-end (test-agenda-query-occ--epoch 0 8 31 7 2026))) + (should-not (test-agenda-query-occ--of "<2026-07-31 Fri 09:00-10:00>" + win-start win-end)) + (should-not (test-agenda-query-occ--of "<2026-07-01 Wed 09:00 +1d>" + win-start win-end)))) + +(ert-deftest test-agenda-query-occ-error-nil-timestamp () + "Error: a nil timestamp yields no occurrences rather than signaling." + (should-not (cj/--agenda-query-occurrences nil 0 100))) + +(provide 'test-agenda-query--occurrences) +;;; test-agenda-query--occurrences.el ends here diff --git a/tests/test-agenda-query--render.el b/tests/test-agenda-query--render.el new file mode 100644 index 00000000..da5c3f60 --- /dev/null +++ b/tests/test-agenda-query--render.el @@ -0,0 +1,282 @@ +;;; test-agenda-query--render.el --- Tests for the renderer profile -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/agenda-render-json' and the row transform behind it. +;; +;; The renderer reads three keys — s and e as epoch MILLISECONDS, t as the +;; title — and drops everything else before drawing. Two things therefore have +;; to hold, and both are asserted rather than assumed: +;; +;; 1. s and e really are milliseconds. A seconds-for-milliseconds slip puts +;; every bar in 1970 and the surface renders empty, which looks exactly like +;; "Emacs isn't writing the file". +;; 2. Every row has a drawable e. The canonical profile reports null where the +;; source has no range, and null is not a width. +;; +;; Helpers carry a file-unique prefix: the editor hook loads every +;; agenda-query test file into ONE process. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) +;; Supplies `cj/org-todo-keywords', the vocabulary the batch writer sets and +;; the editor's org config reads. +(require 'user-constants) + +(defun test-aq-render--epoch (min hour day month year) + "Return the epoch for local MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list 0 min hour day month year nil -1 nil)) + 'integer)) + +(defmacro test-aq-render--with-agenda-file (text &rest body) + "Write TEXT to a temp agenda file and run BODY with `rows' bound. +`rows' is the parsed render-profile output for all of 2026-07-31." + (declare (indent 1)) + `(let* ((dir (make-temp-file "agenda-render-" t)) + (file (expand-file-name "todo.org" dir))) + (unwind-protect + (progn + (with-temp-file file (insert ,text)) + (let* ((org-agenda-files (list file)) + (rows (append (json-parse-string + (cj/agenda-render-json + (test-aq-render--epoch 0 0 31 7 2026) + (test-aq-render--epoch 59 23 31 7 2026)) + :object-type 'alist) + nil))) + ,@body)) + (dolist (buffer (buffer-list)) + (when (equal (buffer-file-name buffer) file) (kill-buffer buffer))) + (delete-directory dir t)))) + +;;; Normal Cases + +(ert-deftest test-agenda-render-normal-emits-milliseconds () + "Normal: s and e are epoch milliseconds, not seconds. + +The renderer works in milliseconds throughout. Sending seconds puts every bar +in January 1970, which draws as an empty surface — indistinguishable from the +file never being written." + (test-aq-render--with-agenda-file + "* Standup\nSCHEDULED: <2026-07-31 Fri 09:00-09:30>\n" + (let ((row (car rows))) + (should (= (alist-get 's row) + (* 1000 (test-aq-render--epoch 0 9 31 7 2026)))) + (should (= (alist-get 'e row) + (* 1000 (test-aq-render--epoch 30 9 31 7 2026)))) + ;; Sanity on the magnitude: milliseconds since 1970 are 13 digits now. + (should (= 13 (length (number-to-string (alist-get 's row)))))))) + +(ert-deftest test-agenda-render-normal-title-is-t () + "Normal: the title is carried as t, the key the renderer reads." + (test-aq-render--with-agenda-file + "* TODO [#A] Standup with Nerses :work:\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "Standup with Nerses" (alist-get 't (car rows)))))) + +(ert-deftest test-agenda-render-normal-canonical-fields-survive () + "Normal: the canonical fields ride along, since the consumer drops its own. +One file serves both the renderer and anything reading the documented shape." + (test-aq-render--with-agenda-file + "* DONE Standup\nSCHEDULED: <2026-07-31 Fri 09:00-09:30>\n" + (let ((row (car rows))) + (should (equal "Standup" (alist-get 'title row))) + (should (eq t (alist-get 'done row))) + (should (equal "scheduled" (alist-get 'type row))) + ;; start stays SECONDS while s is milliseconds; the units never mix + ;; within a key. + (should (= (alist-get 'start row) (/ (alist-get 's row) 1000)))))) + +;;; Boundary Cases + +(ert-deftest test-agenda-render-boundary-all-day-spans-its-day () + "Boundary: an all-day entry gets a drawable e covering its whole day. +Canonically its end is null, and null is not something a renderer can draw." + (test-aq-render--with-agenda-file + "* TODO Water plants\nSCHEDULED: <2026-07-31 Fri>\n" + (let ((row (car rows))) + (should (eq :null (alist-get 'end row))) + (should (= (alist-get 's row) + (* 1000 (test-aq-render--epoch 0 0 31 7 2026)))) + (should (= (alist-get 'e row) + (* 1000 (1- (test-aq-render--epoch 0 0 1 8 2026)))))))) + +(ert-deftest test-agenda-render-boundary-point-event-has-zero-width () + "Boundary: a timed point event ends where it starts rather than at null. +Zero width is a marker the renderer can decide how to draw; null is a crash or +a silently dropped row." + (test-aq-render--with-agenda-file + "* Reminder\n<2026-07-31 Fri 14:00>\n" + (let ((row (car rows))) + (should (eq :null (alist-get 'end row))) + (should (= (alist-get 'e row) (alist-get 's row)))))) + +(ert-deftest test-agenda-render-boundary-every-row-is-drawable () + "Boundary: across a mixed day, every row has integer s and e with e >= s. +This is the invariant the surface depends on, so it is asserted over the whole +set rather than one row at a time." + (test-aq-render--with-agenda-file + (concat "* TODO All day\nSCHEDULED: <2026-07-31 Fri>\n" + "* Point\n<2026-07-31 Fri 14:00>\n" + "* Ranged\n<2026-07-31 Fri 15:00-16:30>\n" + "* TODO Deadline day\nDEADLINE: <2026-07-31 Fri 17:00>\n") + (should (= 4 (length rows))) + (dolist (row rows) + (should (integerp (alist-get 's row))) + (should (integerp (alist-get 'e row))) + (should (>= (alist-get 'e row) (alist-get 's row))) + (should (stringp (alist-get 't row)))))) + +(ert-deftest test-agenda-render-boundary-empty-is-array () + "Boundary: an empty day is an empty array, not null. +The renderer parses the same shape whether or not anything is scheduled." + (let ((org-agenda-files nil)) + (should (equal "[]" (cj/agenda-render-json 1785474000 1785477600))))) + +;;; ---------- the batch reader has to know the keyword vocabulary ---------- + +(ert-deftest test-agenda-render-normal-custom-keyword-is-parsed () + "Normal: a config keyword is recognised, so it leaves the title. + +The batch writer runs without the editor's init, so it has to set +`org-todo-keywords' itself. When it does not, org stops parsing the headline +as a task at all: DOING and the priority cookie stay glued to the front of the +title and the row reads as having no keyword. That is a wrong answer that +still parses as JSON, which is the worst kind." + (let ((org-todo-keywords cj/org-todo-keywords)) + (test-aq-render--with-agenda-file + "* DOING [#A] Justin Johns advisor projects\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (let ((row (car rows))) + (should (equal "Justin Johns advisor projects" (alist-get 't row))) + (should (equal "DOING" (alist-get 'keyword row))))))) + +(ert-deftest test-agenda-render-boundary-unknown-keyword-stays-in-title () + "Boundary: with stock keywords the same headline degrades visibly. + +Pinning the failure mode, not endorsing it. This is what the surface showed +before the batch writer learned the vocabulary, and it is why the test above +exists." + ;; 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 three whole local days and creates its dir. + +Yesterday's midnight through tomorrow's day close. A consumer drawing a +rolling window centred on now needs both sides of midnight: with a single +calendar day, the part of its span outside today has nothing to draw, which +late in the evening is half the surface. + +This is the function that actually ships the feature, so it gets its own +coverage rather than riding on the tests for the profile beneath it. The +window assertion is the point: a writer that quietly covered the last hour, +or the next 24 from now, would still produce a plausible-looking file." + (let* ((dir (make-temp-file "agenda-cache-" t)) + ;; A path two levels deep, so directory creation is exercised. + (cj/agenda-render-cache-file + (expand-file-name "settings/agenda.json" dir)) + (org-agenda-files nil) + (windows '())) + (unwind-protect + (cl-letf (((symbol-function 'cj/agenda-render-json) + (lambda (start end &optional out) + (push (cons start end) windows) + (when out (cj/--agenda-query-write-atomically out "[]")) + "[]"))) + (should (equal cj/agenda-render-cache-file + (cj/agenda-render-cache-update))) + (should (file-exists-p cj/agenda-render-cache-file)) + (let* ((window (car windows)) + (start (decode-time (car window))) + (now (decode-time))) + ;; Opens at local midnight... + (should (= 0 (nth 2 start))) + (should (= 0 (nth 1 start))) + (should (= 0 (nth 0 start))) + ;; ...on yesterday, and closes at the end of tomorrow. + (should (= (car window) + (cj/--agenda-query-epoch + 0 0 0 (1- (nth 3 now)) (nth 4 now) (nth 5 now)))) + (should (= (cdr window) + (cj/--agenda-query-day-close + (1+ (nth 3 now)) (nth 4 now) (nth 5 now)))) + ;; Three whole days, give or take an hour at a DST changeover. + (let ((hours (/ (- (cdr window) (car window)) 3600.0))) + (should (>= hours 70.9)) + (should (<= hours 73.1))))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-render-boundary-cache-update-is-idempotent () + "Boundary: writing twice leaves one file and no temp litter." + (let* ((dir (make-temp-file "agenda-cache-" t)) + (cj/agenda-render-cache-file (expand-file-name "agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (cj/agenda-render-cache-update) + (cj/agenda-render-cache-update) + (should (equal '("agenda.json") + (directory-files + dir nil directory-files-no-dot-files-regexp)))) + (delete-directory dir t)))) + +;;; Error Cases + +(ert-deftest test-agenda-render-error-cache-update-unwritable-parent () + "Error: an unwritable cache location signals rather than failing silently. +A silent failure here looks identical to an empty agenda on the surface." + (let* ((dir (make-temp-file "agenda-cache-ro-" t)) + (cj/agenda-render-cache-file + (expand-file-name "settings/agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (set-file-modes dir #o500) + (should-error (cj/agenda-render-cache-update))) + (set-file-modes dir #o700) + (delete-directory dir t)))) + +(ert-deftest test-agenda-render-error-bounds-are-still-seconds () + "Error: the render profile takes SECONDS in, even though it emits +milliseconds. The direction of conversion is one-way and the input guards +still apply, so a caller passing milliseconds is told rather than answered." + (let ((org-agenda-files nil) + (ms 1785474000000)) + (should-error (cj/agenda-render-json ms (+ ms 3600000)) :type 'user-error))) + +;;; Back to Normal Cases -- the profile's own writer + +(ert-deftest test-agenda-render-normal-writes-out-path () + "Normal: with an out-path the render profile writes it atomically." + (let* ((dir (make-temp-file "agenda-render-out-" t)) + (out (expand-file-name "agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (cj/agenda-render-json 1785474000 1785477600 out) + (should (file-exists-p out)) + (with-temp-buffer + (insert-file-contents out) + (should (equal "[]" (buffer-string)))) + (should (zerop (logand (file-modes out) #o111)))) + (delete-directory dir t)))) + +(provide 'test-agenda-query--render) +;;; test-agenda-query--render.el ends here diff --git a/tests/test-agenda-query.el b/tests/test-agenda-query.el new file mode 100644 index 00000000..4b6b0dc1 --- /dev/null +++ b/tests/test-agenda-query.el @@ -0,0 +1,381 @@ +;;; test-agenda-query.el --- Tests for the agenda JSON query -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `cj/--agenda-query-buffer-events', `cj/agenda-window-json' and the +;; atomic writer. +;; +;; The load-bearing test here is the SCHEDULED/DEADLINE one. Org stores +;; planning timestamps as properties on a `planning' element rather than as +;; children in the parse tree, so the obvious implementation -- mapping over +;; \='timestamp -- returns neither, silently. A fixture without a SCHEDULED +;; entry would pass against that broken implementation, so every fixture that +;; matters carries one. +;; +;; Helpers carry a file-unique prefix on purpose: the editor hook loads every +;; agenda-query test file into ONE process, so a shared helper name here would +;; silently redefine its namesake in a sibling file. + +;;; Code: + +(require 'ert) +(require 'org) +(require 'org-element) +(require 'org-agenda) +(require 'seq) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'agenda-query) + +(defun test-aq-json--epoch (min hour day month year) + "Return the epoch for local MIN HOUR DAY MONTH YEAR." + (time-convert (encode-time (list 0 min hour day month year nil -1 nil)) + 'integer)) + +(defun test-aq-json--day-window () + "Return the window covering all of 2026-07-31 as a cons." + (cons (test-aq-json--epoch 0 0 31 7 2026) + (test-aq-json--epoch 59 23 31 7 2026))) + +(defmacro test-aq-json--with-org (text &rest body) + "Parse TEXT in an org-mode buffer and run BODY with `events' bound. +`events' holds the rows the buffer contributes for all of 2026-07-31." + (declare (indent 1)) + `(with-temp-buffer + (insert ,text) + (org-mode) + (let* ((window (test-aq-json--day-window)) + (events (cj/--agenda-query-buffer-events + (current-buffer) "/tmp/fixture.org" + (car window) (cdr window)))) + ,@body))) + +(defun test-aq-json--field (event key) + "Return EVENT's KEY, a symbol." + (alist-get key event)) + +(defun test-aq-json--of-type (events type) + "Return the EVENTS whose type is TYPE." + (seq-filter (lambda (e) (equal type (test-aq-json--field e 'type))) events)) + +(defmacro test-aq-json--with-agenda-file (text &rest body) + "Write TEXT to a temp agenda file and run BODY with `file' and `window' bound. +Kills the visited buffer afterwards so the run leaves no state behind." + (declare (indent 1)) + `(let* ((dir (make-temp-file "agenda-query-" t)) + (file (expand-file-name "todo.org" dir)) + (window (test-aq-json--day-window))) + (unwind-protect + (progn + (with-temp-file file (insert ,text)) + (let ((org-agenda-files (list file))) + ,@body)) + (dolist (buffer (buffer-list)) + (when (equal (buffer-file-name buffer) file) (kill-buffer buffer))) + (delete-directory dir t)))) + +;;; ---------- the planning-property trap ---------- + +(ert-deftest test-agenda-query-normal-scheduled-and-deadline-are-found () + "Normal: SCHEDULED and DEADLINE both reach the output. + +These are properties on the planning element, not children in the parse tree. +An implementation that maps over \='timestamp returns the body stamp only and +drops these two silently -- so this asserts they are present, not merely that +the count is right." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00> DEADLINE: <2026-07-31 Fri 17:00>\nBody <2026-07-31 Fri 14:00>\n" + (should (= 1 (length (test-aq-json--of-type events "scheduled")))) + (should (= 1 (length (test-aq-json--of-type events "deadline")))) + (should (= 1 (length (test-aq-json--of-type events "timestamp")))) + (should (equal (test-aq-json--epoch 0 9 31 7 2026) + (test-aq-json--field + (car (test-aq-json--of-type events "scheduled")) 'start))) + (should (equal (test-aq-json--epoch 0 17 31 7 2026) + (test-aq-json--field + (car (test-aq-json--of-type events "deadline")) 'start))))) + +(ert-deftest test-agenda-query-normal-scheduled-alone-is-found () + "Normal: an entry whose only timestamp is SCHEDULED still produces a row. +The positive control for the trap: with no body timestamp to mask it, a broken +implementation returns nothing at all here." + (test-aq-json--with-org + "* TODO Water plants\nSCHEDULED: <2026-07-31 Fri>\n" + (should (= 1 (length events))) + (should (equal "scheduled" (test-aq-json--field (car events) 'type))))) + +;;; ---------- field content ---------- + +(ert-deftest test-agenda-query-normal-title-is-stripped () + "Normal: the title carries no keyword, priority cookie or tags." + (test-aq-json--with-org + "* TODO [#A] Standup with Nerses :work:urgent:\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "Standup with Nerses" + (test-aq-json--field (car events) 'title))))) + +(ert-deftest test-agenda-query-normal-title-renders-org-links () + "Normal: an org link in the title becomes its description text. + +Craig's captured web items carry link syntax in the headline, so this is not +hypothetical -- his live agenda has one today. A wallpaper showing +\"[[https://…][Tracking your habits]]\" is a bug the consumer cannot fix +without parsing org markup." + (test-aq-json--with-org + "* TODO [[https://orgmode.org/x][Tracking your habits]]\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "Tracking your habits" + (test-aq-json--field (car events) 'title)))) + ;; A bare link has no description, so its target is the best available text. + (test-aq-json--with-org + "* TODO [[https://orgmode.org/x]]\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (equal "https://orgmode.org/x" + (test-aq-json--field (car events) 'title))))) + +(ert-deftest test-agenda-query-normal-location-and-organizer () + "Normal: LOCATION and ORGANIZER properties reach the row." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n:PROPERTIES:\n:LOCATION: Room 3\n:ORGANIZER: Nerses\n:END:\n" + (should (equal "Room 3" (test-aq-json--field (car events) 'location))) + (should (equal "Nerses" (test-aq-json--field (car events) 'organizer))))) + +(ert-deftest test-agenda-query-normal-completion-state () + "Normal: a closed entry reports done true and keeps its raw keyword. +Without this a DONE task carrying today's SCHEDULED renders as an upcoming +event, and the error compounds over a working day." + (test-aq-json--with-org + "* DONE Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (eq t (test-aq-json--field (car events) 'done))) + (should (equal "DONE" (test-aq-json--field (car events) 'keyword))))) + +(ert-deftest test-agenda-query-boundary-open-task-is-not-done () + "Boundary: an open task reports done false, not null or missing." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (eq :false (test-aq-json--field (car events) 'done))) + (should (equal "TODO" (test-aq-json--field (car events) 'keyword))))) + +(ert-deftest test-agenda-query-boundary-plain-headline-has-null-keyword () + "Boundary: an entry with no keyword reports null rather than an empty string." + (test-aq-json--with-org + "* Lunch\n<2026-07-31 Fri 12:00-13:00>\n" + (should (eq :null (test-aq-json--field (car events) 'keyword))) + (should (eq :false (test-aq-json--field (car events) 'done))))) + +(ert-deftest test-agenda-query-boundary-repeater-cookie-in-row () + "Boundary: a repeating entry carries its raw cookie so the consumer can mark it." + (test-aq-json--with-org + "* TODO Water plants\nSCHEDULED: <2026-07-01 Wed 09:00 +1d>\n" + (should (= 1 (length events))) + (should (equal "+1d" (test-aq-json--field (car events) 'repeater))) + (should (equal (test-aq-json--epoch 0 9 31 7 2026) + (test-aq-json--field (car events) 'start))))) + +(ert-deftest test-agenda-query-boundary-absent-fields-are-null () + "Boundary: absent optional values are null, so the shape stays stable." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-07-31 Fri>\n" + (let ((event (car events))) + (should (eq :null (test-aq-json--field event 'end))) + (should (eq :null (test-aq-json--field event 'location))) + (should (eq :null (test-aq-json--field event 'organizer))) + (should (eq :null (test-aq-json--field event 'repeater))) + (should (eq t (test-aq-json--field event 'all-day)))))) + +;;; ---------- selection ---------- + +(ert-deftest test-agenda-query-boundary-inactive-excluded () + "Boundary: an inactive timestamp never reaches an agenda, so it is excluded." + (test-aq-json--with-org + "* Note\nLogged [2026-07-31 Fri 10:00]\n" + (should-not events))) + +(ert-deftest test-agenda-query-boundary-nested-headlines-not-double-counted () + "Boundary: a child's timestamp belongs to the child alone. +Collecting per-headline by mapping a headline's whole subtree would attribute +each child stamp to every ancestor too." + (test-aq-json--with-org + "* Parent\nSCHEDULED: <2026-07-31 Fri 09:00>\n** Child\nSCHEDULED: <2026-07-31 Fri 11:00>\n" + (should (= 2 (length events))) + (should (equal '("Parent" "Child") + (mapcar (lambda (e) (test-aq-json--field e 'title)) events))))) + +(ert-deftest test-agenda-query-boundary-archived-and-commented-excluded () + "Boundary: archived and commented subtrees are skipped, as org's agenda does. +A query that disagrees with the agenda Craig sees is worse than one returning +less, and both of these are off his agenda." + (test-aq-json--with-org + (concat "* Archived thing :ARCHIVE:\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + "* COMMENT Commented\nSCHEDULED: <2026-07-31 Fri 10:00>\n" + "* Live\nSCHEDULED: <2026-07-31 Fri 11:00>\n") + (should (equal '("Live") + (mapcar (lambda (e) (test-aq-json--field e 'title)) events))))) + +(ert-deftest test-agenda-query-boundary-archive-applies-to-children () + "Boundary: archiving a parent takes its whole subtree off the agenda." + (test-aq-json--with-org + (concat "* Parent :ARCHIVE:\n** Child\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + "* Live\nSCHEDULED: <2026-07-31 Fri 11:00>\n") + (should (equal '("Live") + (mapcar (lambda (e) (test-aq-json--field e 'title)) events))))) + +(ert-deftest test-agenda-query-boundary-outside-window-excluded () + "Boundary: an entry on another day contributes nothing." + (test-aq-json--with-org + "* TODO Standup\nSCHEDULED: <2026-08-15 Sat 09:00>\n" + (should-not events))) + +(ert-deftest test-agenda-query-boundary-empty-buffer () + "Boundary: an empty buffer yields no rows." + (test-aq-json--with-org "" (should-not events))) + +;;; ---------- error cases ---------- + +(ert-deftest test-agenda-query-error-diary-sexp-is-skipped () + "Error: a diary sexp timestamp cannot expand to an instant, and is skipped +without signaling -- one unusable entry must not fail the whole query." + (test-aq-json--with-org + "* Floating\n<%%(diary-float t 3 3)>\n* TODO Standup\nSCHEDULED: <2026-07-31 Fri 09:00>\n" + (should (= 1 (length events))) + (should (equal "Standup" (test-aq-json--field (car events) 'title))))) + +(ert-deftest test-agenda-query-error-headline-without-timestamp () + "Error: an entry with no timestamp at all contributes nothing." + (test-aq-json--with-org "* TODO Someday\nJust prose.\n" + (should-not events))) + +;;; ---------- JSON output ---------- + +(ert-deftest test-agenda-query-normal-json-round-trips () + "Normal: the output parses as JSON and preserves the fields. +Booleans arrive as real JSON booleans and absent values as null, so the +consumer can test on them rather than string-matching." + (test-aq-json--with-agenda-file + "* DONE Standup\nSCHEDULED: <2026-07-31 Fri 09:00-09:30>\n" + (let* ((json (cj/agenda-window-json (car window) (cdr window))) + (parsed (json-parse-string json :object-type 'alist))) + (should (= 1 (length parsed))) + (let ((event (aref parsed 0))) + (should (equal "Standup" (alist-get 'title event))) + (should (eq t (alist-get 'done event))) + (should (eq :false (alist-get 'all-day event))) + (should (equal file (alist-get 'file event))) + (should (eq :null (alist-get 'repeater event))) + (should (equal (test-aq-json--epoch 30 9 31 7 2026) + (alist-get 'end event))))))) + +(ert-deftest test-agenda-query-boundary-json-empty-is-array () + "Boundary: an empty result is an empty JSON array, never null. +The consumer parses the same shape whether or not anything is scheduled." + (let ((org-agenda-files nil)) + (should (equal "[]" (cj/agenda-window-json 0 100))))) + +(ert-deftest test-agenda-query-boundary-json-sorted-by-start () + "Boundary: rows come back in start order regardless of file order." + (test-aq-json--with-agenda-file + "* Late\nSCHEDULED: <2026-07-31 Fri 17:00>\n* Early\nSCHEDULED: <2026-07-31 Fri 08:00>\n" + (let ((parsed (json-parse-string + (cj/agenda-window-json (car window) (cdr window)) + :object-type 'alist))) + (should (equal '("Early" "Late") + (mapcar (lambda (e) (alist-get 'title e)) + (append parsed nil))))))) + +(ert-deftest test-agenda-query-error-json-rejects-non-numeric-bounds () + "Error: a non-numeric bound signals rather than returning a wrong answer." + (should-error (cj/agenda-window-json "now" 100) :type 'wrong-type-argument) + (should-error (cj/agenda-window-json 0 nil) :type 'wrong-type-argument)) + +(ert-deftest test-agenda-query-error-rejects-absurdly-wide-window () + "Error: a window wider than the cap signals instead of trying to answer. + +This is the milliseconds-for-seconds mistake, which a JavaScript consumer +makes by passing `Date.now()' straight through. Answering it means building +tens of millions of rows inside the daemon Craig is working in; a renderer +losing one frame is much the cheaper failure." + (let ((org-agenda-files nil) + (now 1785474000)) + (should-error (cj/agenda-window-json now (* now 1000)) :type 'user-error) + ;; A window at the cap is still answered. + (should (equal "[]" (cj/agenda-window-json + now (+ now cj/agenda-query-max-window-seconds)))))) + +(ert-deftest test-agenda-query-error-rejects-millisecond-bounds () + "Error: BOTH bounds in milliseconds is rejected on magnitude. + +This is the likelier shape of the units mistake and the width cap cannot see +it: `Date.now()' and `Date.now() + 3600000' look like a 41-day window, so it +passes the width check and answers with timestamps in the year 58549. A +wrong answer that parses is worse than an error." + (let ((org-agenda-files nil) + (ms 1785474000000)) + (should-error (cj/agenda-window-json ms (+ ms 3600000)) :type 'user-error) + ;; The same instants in seconds are a perfectly ordinary request. + (should (equal "[]" (cj/agenda-window-json 1785474000 1785477600))))) + +;;; ---------- atomic write ---------- + +(ert-deftest test-agenda-query-normal-writes-file-atomically () + "Normal: OUT-PATH receives the JSON and no temp file is left behind." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (out (expand-file-name "agenda.json" dir)) + (org-agenda-files nil)) + (unwind-protect + (progn + (should (equal "[]" (cj/agenda-window-json 0 100 out))) + (should (file-exists-p out)) + (with-temp-buffer + (insert-file-contents out) + (should (equal "[]" (buffer-string)))) + ;; The rename consumed the temp file; only the target remains. + (should (equal '("agenda.json") + (directory-files + dir nil directory-files-no-dot-files-regexp)))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-query-boundary-write-is-readable-by-others () + "Boundary: the written file is not left at the temp file's private 0600. + +`make-temp-file' creates 0600, and the rename carries that mode onto the +target. The whole point of OUT-PATH is that another process reads it, so a +private mode would work only while the reader runs as Craig." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (out (expand-file-name "agenda.json" dir))) + (unwind-protect + (progn + (cj/--agenda-query-write-atomically out "[]") + ;; Readable beyond the owner, following the session umask... + (should (= (logand (file-modes out) #o044) + (logand #o044 (default-file-modes)))) + ;; ...but never executable. `default-file-modes' is 777 minus the + ;; umask, so using it unmasked publishes the JSON as 0755. + ;; No assertion that the mode differs from 0600: under umask 077 + ;; that IS the correct answer, and asserting otherwise would fail + ;; for a reason that has nothing to do with this code. + (should (zerop (logand (file-modes out) #o111)))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-query-boundary-write-replaces-existing () + "Boundary: an existing file is replaced wholesale, not appended to." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (out (expand-file-name "agenda.json" dir))) + (unwind-protect + (progn + (with-temp-file out (insert "stale content that is much longer")) + (cj/--agenda-query-write-atomically out "[]") + (with-temp-buffer + (insert-file-contents out) + (should (equal "[]" (buffer-string))))) + (delete-directory dir t)))) + +(ert-deftest test-agenda-query-error-write-to-missing-dir-preserves-target () + "Error: a write into a nonexistent directory signals and litters nothing." + (let* ((dir (make-temp-file "agenda-query-out-" t)) + (missing (expand-file-name "nope/agenda.json" dir))) + (unwind-protect + (progn + (should-error (cj/--agenda-query-write-atomically missing "[]")) + (should-not (file-exists-p missing)) + (should-not (directory-files + dir nil directory-files-no-dot-files-regexp))) + (delete-directory dir t)))) + +(provide 'test-agenda-query) +;;; test-agenda-query.el ends here diff --git a/tests/test-agenda-render-cache.bats b/tests/test-agenda-render-cache.bats new file mode 100644 index 00000000..3e949c16 --- /dev/null +++ b/tests/test-agenda-render-cache.bats @@ -0,0 +1,131 @@ +#!/usr/bin/env bats +# Tests for scripts/agenda-render-cache — the batch writer behind the timer. +# +# The elisp tests cover the query and the row shape. What only a shell test +# can cover is the thing that actually broke: the script runs a batch Emacs +# with -Q, so none of the editor's configuration is loaded, and anything it +# forgets to set up degrades silently rather than erroring. The first version +# wrote a file that parsed fine and was wrong, because org did not know DOING +# was a keyword and left it glued to the front of every title. +# +# Two isolation rules, both learned the hard way: +# +# EMACS_D points at THIS checkout, not $HOME/.emacs.d. Without it the script +# under test runs the installed config's elisp, so a broken tree passes. +# +# AGENDA_RENDER_FILES points at a fixture written here. Asserting over the +# machine's real agenda makes the result depend on what Craig happens to have +# scheduled today: the keyword assertion only bites if some entry carries a +# keyword, and on an empty agenda every all() assertion passes over an empty +# list. The fixture makes the failure mode reachable every run. + +setup() { + SCRIPT="${BATS_TEST_DIRNAME}/../scripts/agenda-render-cache" + export EMACS_D="${BATS_TEST_DIRNAME}/.." + export XDG_CACHE_HOME="${BATS_TEST_TMPDIR}/cache" + OUT="${XDG_CACHE_HOME}/settings/agenda.json" + + FIXTURE="${BATS_TEST_TMPDIR}/fixture.org" + TODAY="$(date +%Y-%m-%d)" + DOW="$(date +%a)" + { + printf '* DOING [#A] Advisor projects\nSCHEDULED: <%s %s 09:00>\n' "$TODAY" "$DOW" + printf '* TODO Standup\nSCHEDULED: <%s %s 10:00-10:15>\n' "$TODAY" "$DOW" + printf '* Lunch\n<%s %s 12:00-13:00>\n' "$TODAY" "$DOW" + printf '* VERIFY [#B] Check the render\nDEADLINE: <%s %s 17:00>\n' "$TODAY" "$DOW" + } > "$FIXTURE" + export AGENDA_RENDER_FILES="$FIXTURE" +} + +# Every assertion below runs through this, so an empty result can never pass +# vacuously — all() over an empty list is true, which is how a writer that +# produced nothing would look like a writer that produced correct rows. +assert_json() { + python3 -c " +import json, sys +rows = json.load(open(sys.argv[1])) +assert isinstance(rows, list), 'not a JSON array' +assert len(rows) == 4, 'expected 4 fixture rows, got %d' % len(rows) +$1 +" "$OUT" +} + +@test "the script is executable" { + [ -x "$SCRIPT" ] +} + +@test "writes a parseable JSON array and creates its directory" { + run "$SCRIPT" + [ "$status" -eq 0 ] + [ -f "$OUT" ] + run assert_json "pass" + [ "$status" -eq 0 ] +} + +@test "every row carries the three keys the renderer reads" { + run "$SCRIPT" + [ "$status" -eq 0 ] + run assert_json " +assert all({'s','e','t'} <= set(r) for r in rows), 'missing s/e/t' +assert all(isinstance(r['s'], int) and isinstance(r['e'], int) for r in rows), 'non-integer instant' +assert all(r['e'] >= r['s'] for r in rows), 'negative duration' +" + [ "$status" -eq 0 ] +} + +@test "instants are milliseconds, not seconds" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # Seconds since 1970 are 10 digits; milliseconds are 13. + run assert_json "assert all(len(str(r['s'])) == 13 for r in rows), 'looks like seconds'" + [ "$status" -eq 0 ] +} + +@test "titles do not carry the TODO keyword vocabulary" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # The regression this file exists for. The fixture carries DOING, TODO and + # VERIFY entries plus two priority cookies, so a script that has not set + # org-todo-keywords fails here every run rather than only on days when + # Craig happens to have such an entry. + run assert_json " +KEYWORDS = {'TODO','PROJECT','DOING','WAITING','VERIFY','STALLED', + 'DELEGATED','FAILED','DONE','CANCELLED'} +bad = [r['t'] for r in rows if r['t'].split(' ')[0] in KEYWORDS] +assert not bad, 'keyword left in title: %r' % bad +cookie = [r['t'] for r in rows if r['t'].startswith('[#')] +assert not cookie, 'priority cookie left in title: %r' % cookie +assert sorted(r['t'] for r in rows) == [ + 'Advisor projects', 'Check the render', 'Lunch', 'Standup'] +" + [ "$status" -eq 0 ] +} + +@test "keyword and completion state survive the batch environment" { + run "$SCRIPT" + [ "$status" -eq 0 ] + run assert_json " +by_title = {r['t']: r for r in rows} +assert by_title['Advisor projects']['keyword'] == 'DOING', by_title['Advisor projects'] +assert by_title['Check the render']['keyword'] == 'VERIFY' +assert by_title['Lunch']['keyword'] is None +assert all(r['done'] is False for r in rows) +assert by_title['Check the render']['type'] == 'deadline' +" + [ "$status" -eq 0 ] +} + +@test "replaces an existing file rather than appending" { + mkdir -p "$(dirname "$OUT")" + printf 'stale garbage that is not json at all\n' > "$OUT" + run "$SCRIPT" + [ "$status" -eq 0 ] + run assert_json "pass" + [ "$status" -eq 0 ] +} + +@test "fails loudly when the config directory is missing" { + run env EMACS_D="${BATS_TEST_TMPDIR}/nonexistent" "$SCRIPT" + [ "$status" -ne 0 ] + [[ "$output" == *"no modules directory"* ]] +} diff --git a/tests/test-auto-dim-config.el b/tests/test-auto-dim-config.el index dcab7eff..8b13fbb0 100644 --- a/tests/test-auto-dim-config.el +++ b/tests/test-auto-dim-config.el @@ -30,16 +30,105 @@ (progn (should (bound-and-true-p auto-dim-other-buffers-mode)) (should (null auto-dim-other-buffers-dim-on-focus-out)) - ;; Entering the minibuffer must not change what is dimmed: a dim window - ;; stays dim, a lit one stays lit. The fork's `adob--update' returns - ;; early when this is nil and the selected window is the minibuffer, so - ;; nil is what keeps a minibuffer prompt from re-dimming the window the - ;; user was just in. + ;; Config intent only: this asserts the value the module just set, so it + ;; cannot fail even if the fork inverts what the flag MEANS. The two + ;; behavioral tests below are what actually pin the behavior. (should (null auto-dim-other-buffers-dim-on-switch-to-minibuffer)) (should-not (assq 'fringe auto-dim-other-buffers-affected-faces))) (when (fboundp 'auto-dim-other-buffers-mode) (auto-dim-other-buffers-mode -1)))) +(defmacro test-auto-dim--with-two-windows (win-a win-b &rest body) + "Bind WIN-A and WIN-B to two live windows with the mode on, then run BODY. +Restores the window configuration, the buffers, and the mode's PRIOR state. +Restoring rather than force-disabling matters: `auto-dim-other-buffers-mode' is +global, and switching it off unconditionally left a later test in this file +asserting the mode is on with it off. That only stayed hidden because ERT runs +tests alphabetically and the asserting test sorts first." + (declare (indent 2)) + `(let ((config (current-window-configuration)) + (was-on (bound-and-true-p auto-dim-other-buffers-mode))) + (unwind-protect + (let* ((,win-a (selected-window)) + (,win-b (split-window))) + (set-window-buffer ,win-a (get-buffer-create " *adob-a*")) + (set-window-buffer ,win-b (get-buffer-create " *adob-b*")) + (select-window ,win-a) + (auto-dim-other-buffers-mode 1) + ,@body) + (when (fboundp 'auto-dim-other-buffers-mode) + (auto-dim-other-buffers-mode (if was-on 1 -1))) + (set-window-configuration config) + (dolist (name '(" *adob-a*" " *adob-b*")) + (when (get-buffer name) (kill-buffer name)))))) + +(ert-deftest test-auto-dim-config-minibuffer-entry-leaves-previous-window-lit () + "Normal: with the flag nil, entering the minibuffer leaves the previous window lit. +This is the half that works, and the reason the flag is set to nil. + +Deliberately asserts the composite behavior rather than naming one function. +Selecting the minibuffer fires the mode's own hooks, so the observable outcome is +not attributable to the explicit `adob--update' call alone -- and the observable +outcome is what the setting promises the user. + +The `win-b' assertions are positive controls. Without them this test passes +against an implementation where dimming is broken everywhere, which looks +identical to the implementation being correct." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (test-auto-dim--with-two-windows win-a win-b + (adob--rescan-windows) + (should (null (window-parameter win-a 'adob--dim))) + (should (window-parameter win-b 'adob--dim)) + (select-window (minibuffer-window)) + (adob--update) + (should (null (window-parameter win-a 'adob--dim))) + (should (window-parameter win-b 'adob--dim)))) + +(ert-deftest test-auto-dim-config-minibuffer-entry-dims-when-flag-is-t () + "Boundary: with the flag t, entering the minibuffer DOES dim the previous window. +This is what gives the nil setting meaning. Without it the suite never shows the +flag changing anything, so the config assertion in +`test-auto-dim-config-applies-settings' has nothing standing behind it." + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (test-auto-dim--with-two-windows win-a win-b + (let ((auto-dim-other-buffers-dim-on-switch-to-minibuffer t)) + (adob--rescan-windows) + (should (null (window-parameter win-a 'adob--dim))) + (select-window (minibuffer-window)) + (adob--update) + (should (window-parameter win-a 'adob--dim))))) + +(ert-deftest test-auto-dim-config-rescan-ignores-the-minibuffer-flag () + "Error: `adob--rescan-windows' dims everything on a minibuffer selection. +Known defect in the fork, pinned here rather than left undocumented. The +rescan is on `window-configuration-change-hook' and dims by window identity +alone -- and `(window-list nil \\='n)' excludes the minibuffer, so when the +minibuffer is selected nothing matches and every window dims. A completion +popup is the everyday case: `adob--update' honours the flag, this does not. + +Expected to fail until the fork honours the flag in the rescan too. When it +starts passing, ERT reports an unexpected pass -- that is the signal to drop +this test and stop treating the gap as open. + +The `win-b' positive control is load-bearing here. Three different broken +implementations -- dimming disabled everywhere, the rescan never setting the +parameter, `adob--update' made a no-op -- all produce an unexpected pass that +would otherwise read as \"the fork fixed it\". Asserting that `win-b' is still +dimmed separates a real fix from dimming having broken." + :expected-result :failed + (skip-unless (file-directory-p test-auto-dim--fork)) + (require 'auto-dim-config) + (test-auto-dim--with-two-windows win-a win-b + (adob--rescan-windows) + (should (null (window-parameter win-a 'adob--dim))) + (should (window-parameter win-b 'adob--dim)) + (select-window (minibuffer-window)) + (adob--rescan-windows) + (should (window-parameter win-b 'adob--dim)) + (should (null (window-parameter win-a 'adob--dim))))) + (defconst test-auto-dim--flat-dimmed-org-faces (append (mapcar (lambda (n) (intern (format "org-level-%d" n))) (number-sequence 1 8)) diff --git a/tests/test-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--expand-monthly.el b/tests/test-calendar-sync--expand-monthly.el index 41b196a7..e9fae901 100644 --- a/tests/test-calendar-sync--expand-monthly.el +++ b/tests/test-calendar-sync--expand-monthly.el @@ -14,9 +14,12 @@ ;;; Normal Cases (ert-deftest test-calendar-sync--expand-monthly-normal-generates-occurrences () - "Test expanding monthly event generates occurrences within range." - (let* ((start-date (test-calendar-sync-time-days-from-now 1 10 0)) - (end-date (test-calendar-sync-time-days-from-now 1 11 0)) + "Test expanding monthly event generates occurrences within range. +Anchored on a day every month has: a series on the 29th, 30th, or 31st +correctly skips the months lacking that day, which is fewer than one per month +and not what this assertion is about." + (let* ((start-date (test-calendar-sync-time-monthly-anchor 10 0)) + (end-date (test-calendar-sync-time-monthly-anchor 11 0)) (base-event (list :summary "Monthly Review" :start start-date :end end-date)) @@ -28,9 +31,13 @@ (should (< (length occurrences) 20)))) (ert-deftest test-calendar-sync--expand-monthly-normal-preserves-day-of-month () - "Test that each occurrence falls on the same day of month." - (let* ((start-date (test-calendar-sync-time-days-from-now 5 10 0)) - (end-date (test-calendar-sync-time-days-from-now 5 11 0)) + "Test that each occurrence falls on the same day of month. +Anchored on a day every month has, so the assertion below can be an equality. +It used to be `<=' against an anchor whose day varied with the run date, which a +skipped month satisfies without ever landing on the right day -- the assertion +held even when the series was wrong." + (let* ((start-date (test-calendar-sync-time-monthly-anchor 10 0)) + (end-date (test-calendar-sync-time-monthly-anchor 11 0)) (expected-day (nth 2 start-date)) (base-event (list :summary "Monthly" :start start-date @@ -39,15 +46,15 @@ (range (test-calendar-sync-wide-range)) (occurrences (calendar-sync--expand-monthly base-event rrule range))) (should (> (length occurrences) 0)) - ;; Day of month should be consistent (may clamp for short months) + ;; Every occurrence lands on the anchor day, exactly. (dolist (occ occurrences) (let ((day (nth 2 (plist-get occ :start)))) - (should (<= day expected-day)))))) + (should (= day expected-day)))))) (ert-deftest test-calendar-sync--expand-monthly-normal-interval-two () "Test expanding bi-monthly event." - (let* ((start-date (test-calendar-sync-time-days-from-now 1 9 0)) - (end-date (test-calendar-sync-time-days-from-now 1 10 0)) + (let* ((start-date (test-calendar-sync-time-monthly-anchor 9 0)) + (end-date (test-calendar-sync-time-monthly-anchor 10 0)) (base-event (list :summary "Bi-Monthly" :start start-date :end end-date)) 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-org-agenda-frame-load-order.el b/tests/test-integration-org-agenda-frame-load-order.el deleted file mode 100644 index 6541d250..00000000 --- a/tests/test-integration-org-agenda-frame-load-order.el +++ /dev/null @@ -1,80 +0,0 @@ -;;; test-integration-org-agenda-frame-load-order.el --- Frame allowlist survives load order -*- lexical-binding: t; -*- - -;;; Commentary: -;; Regression test for a load-order bug in the Full Agenda frame's read-only -;; shadow. -;; -;; Components integrated: -;; - org-agenda-frame (real, loaded in a subprocess) -;; - org-agenda (real, loaded BEFORE the frame module to reproduce the bug) -;; -;; The bug: cj/--agenda-frame-shadow-mutations walks org-agenda-mode-map and -;; keeps a key only when the frame map already binds it to a `commandp' value. -;; The view/redo handlers (day-view, week-view, safe-redo) were defined LOWER in -;; the file than the `with-eval-after-load' that ran the walk. When org-agenda -;; was already loaded at frame-load time -- the normal startup order and every -;; reload -- the walk fired before those defuns existed, read them as not-yet -;; commands, and denied d/w/g/r, the very keys the allowlist grants. Moving the -;; walk to the end of the file (after the defuns) fixed it. -;; -;; This test can't reproduce the ordering in-process (the module is already -;; loaded), so it drives a fresh Emacs that requires org-agenda first, then the -;; frame module, and inspects the resulting keymap. -;; -;; Validates: -;; - d/w/g/r keep their allowlist commands in the org-first load order -;; - a real mutation key (t) is still denied (the read-only guarantee holds) -;; -;;; Code: - -(require 'ert) - -(defconst test-oaf--repo-root - (file-name-directory (directory-file-name - (file-name-directory (or load-file-name buffer-file-name)))) - "Repo root, one level up from tests/.") - -(defun test-oaf--lookup-in-subprocess (keys) - "Load org-agenda then org-agenda-frame in a fresh Emacs, return KEYS' bindings. -Returns an alist of (KEY . BINDING-SYMBOL-NAME-OR-nil)." - (let* ((root test-oaf--repo-root) - (form - (prin1-to-string - `(progn - (setq load-prefer-newer t) - (package-initialize) - (require 'org-agenda) ; the bad order: org first - (require 'org-agenda-frame) - (princ (prin1-to-string - (mapcar - (lambda (k) - (cons k (let ((b (lookup-key cj/agenda-frame-mode-map (kbd k)))) - (and (symbolp b) (symbol-name b))))) - ',keys)))))) - (out (with-output-to-string - (with-current-buffer standard-output - (call-process - (expand-file-name invocation-name invocation-directory) - nil t nil - "--batch" "--no-site-file" "--no-site-lisp" - "-L" root - "-L" (expand-file-name "modules" root) - "-L" (expand-file-name "themes" root) - "--eval" form))))) - (car (read-from-string out)))) - -(ert-deftest test-integration-org-agenda-frame-allowlist-survives-org-first-load () - "Integration: with org-agenda loaded before the frame module, the allowlisted -view/redo keys keep their commands and a mutation key stays denied." - (skip-unless (file-exists-p (expand-file-name "modules/org-agenda-frame.el" - test-oaf--repo-root))) - (let ((got (test-oaf--lookup-in-subprocess '("d" "w" "g" "r" "t")))) - (should (equal "cj/--agenda-frame-day-view" (cdr (assoc "d" got)))) - (should (equal "cj/--agenda-frame-week-view" (cdr (assoc "w" got)))) - (should (equal "cj/--agenda-frame-safe-redo" (cdr (assoc "g" got)))) - (should (equal "cj/--agenda-frame-safe-redo" (cdr (assoc "r" got)))) - ;; t is a real org mutation key; it must be denied, not allowlisted. - (should (equal "cj/--agenda-frame-denied-readonly" (cdr (assoc "t" got)))))) - -(provide 'test-integration-org-agenda-frame-load-order) -;;; test-integration-org-agenda-frame-load-order.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-org-agenda-config--auto-refresh.el b/tests/test-org-agenda-config--auto-refresh.el new file mode 100644 index 00000000..58ef729b --- /dev/null +++ b/tests/test-org-agenda-config--auto-refresh.el @@ -0,0 +1,170 @@ +;;; test-org-agenda-config--auto-refresh.el --- Tests for agenda auto-refresh -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the wall-clock-aligned auto-refresh behind the F8 agenda: +;; the next-mark arithmetic, the on-screen-agenda lookup, the timer body's +;; error containment, and start/stop timer ownership. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'org-agenda-config) + +;; -- Fixtures ---------------------------------------------------------------- + +(defun test-org-agenda-auto-refresh--time (hh mm ss) + "Return an Emacs time value for today at HH:MM:SS local time." + (let ((now (decode-time))) + (encode-time (list ss mm hh + (nth 3 now) (nth 4 now) (nth 5 now) + nil -1 (nth 8 now))))) + +(defmacro test-org-agenda-auto-refresh--with-agenda-window (&rest body) + "Run BODY with a window displaying a buffer in `org-agenda-mode'. +Sets `major-mode' directly rather than calling the mode function: the +lookup under test only asks what mode the window's buffer is in, and +`org-agenda-mode' setup wants a real agenda build behind it." + (declare (indent 0)) + `(let ((buffer (get-buffer-create "*Org Agenda*"))) + (unwind-protect + (save-window-excursion + (with-current-buffer buffer + (setq major-mode 'org-agenda-mode)) + (set-window-buffer (selected-window) buffer) + ,@body) + (kill-buffer buffer)))) + +;; -- cj/--org-agenda-seconds-to-next-mark ------------------------------------ + +(ert-deftest test-org-agenda-config-next-mark-mid-interval () + "Normal: a time between marks returns the remainder to the next one." + (should (= 120 (cj/--org-agenda-seconds-to-next-mark + (test-org-agenda-auto-refresh--time 9 3 0) 300)))) + +(ert-deftest test-org-agenda-config-next-mark-exactly-on-mark () + "Boundary: a time exactly on a mark returns a full period, never zero. +A zero delay would fire the timer immediately and again a period later." + (should (= 300 (cj/--org-agenda-seconds-to-next-mark + (test-org-agenda-auto-refresh--time 9 5 0) 300)))) + +(ert-deftest test-org-agenda-config-next-mark-one-second-before () + "Boundary: one second short of a mark returns one second." + (should (= 1 (cj/--org-agenda-seconds-to-next-mark + (test-org-agenda-auto-refresh--time 9 4 59) 300)))) + +(ert-deftest test-org-agenda-config-next-mark-lands-on-a-multiple () + "Normal: TIME plus the result is always a whole multiple of PERIOD. +This is the property that makes the refresh land on :00/:05 rather than +five minutes after whenever the agenda happened to open." + (dolist (seconds '(0 1 59 60 61 149 150 299)) + (let* ((time (test-org-agenda-auto-refresh--time 9 0 0)) + (start (+ (floor (float-time time)) seconds)) + (delay (cj/--org-agenda-seconds-to-next-mark start 300))) + (should (zerop (mod (+ start delay) 300)))))) + +(ert-deftest test-org-agenda-config-next-mark-rejects-nonpositive-period () + "Error: a zero or negative period is a caller bug, not a silent no-op." + (should-error (cj/--org-agenda-seconds-to-next-mark (current-time) 0)) + (should-error (cj/--org-agenda-seconds-to-next-mark (current-time) -300))) + +;; -- cj/--org-agenda-refresh-window ------------------------------------------ + +(ert-deftest test-org-agenda-config-refresh-window-finds-displayed-agenda () + "Normal: the lookup returns the window showing an agenda buffer." + (test-org-agenda-auto-refresh--with-agenda-window + (should (eq (cj/--org-agenda-refresh-window) (selected-window))))) + +(ert-deftest test-org-agenda-config-refresh-window-nil-when-not-displayed () + "Boundary: an agenda buffer that exists but is off-screen is not a target. +Rebuilding an invisible agenda costs time and shows nobody anything." + (let ((buffer (get-buffer-create "*Org Agenda*"))) + (unwind-protect + (progn + (with-current-buffer buffer (setq major-mode 'org-agenda-mode)) + (should-not (cj/--org-agenda-refresh-window))) + (kill-buffer buffer)))) + +(ert-deftest test-org-agenda-config-refresh-window-nil-with-no-agenda () + "Boundary: no agenda buffer anywhere returns nil rather than erroring." + (should-not (cj/--org-agenda-refresh-window))) + +;; -- cj/--org-agenda-auto-refresh (the timer body) --------------------------- + +(ert-deftest test-org-agenda-config-auto-refresh-noop-without-agenda () + "Boundary: the tick does nothing, and signals nothing, with no agenda up." + (let ((called nil)) + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) (setq called t)))) + (cj/--org-agenda-auto-refresh) + (should-not called)))) + +(ert-deftest test-org-agenda-config-auto-refresh-redoes-visible-agenda () + "Normal: the tick redoes the agenda shown on screen." + (let ((called nil)) + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) (setq called t)))) + (test-org-agenda-auto-refresh--with-agenda-window + (cj/--org-agenda-auto-refresh)) + (should called)))) + +(ert-deftest test-org-agenda-config-auto-refresh-contains-errors () + "Error: a failing redo must not escape the timer body. +An unguarded signal in a repeating timer resignals on every tick, which is +how a five-minute timer turns into an endless backtrace." + (cl-letf (((symbol-function 'org-agenda-redo) + (lambda (&rest _) (error "simulated redo failure"))) + ((symbol-function 'cj/log-silently) (lambda (&rest _) nil))) + (test-org-agenda-auto-refresh--with-agenda-window + (should (progn (cj/--org-agenda-auto-refresh) t))))) + +(ert-deftest test-org-agenda-config-auto-refresh-restores-point-line () + "Normal: the tick leaves point on the line it started on. +A refresh that scrolls the reader back to the top every five minutes is +worse than no refresh." + (cl-letf (((symbol-function 'org-agenda-redo) (lambda (&rest _) nil))) + (test-org-agenda-auto-refresh--with-agenda-window + (with-current-buffer "*Org Agenda*" + (erase-buffer) + (dotimes (i 10) (insert (format "agenda line %d\n" i))) + (goto-char (point-min)) + (forward-line 4)) + (cj/--org-agenda-auto-refresh) + (with-current-buffer "*Org Agenda*" + (should (= 5 (line-number-at-pos))))))) + +;; -- start / stop ------------------------------------------------------------ + +(ert-deftest test-org-agenda-config-auto-refresh-start-owns-one-timer () + "Normal: starting twice leaves exactly one timer, not two. +Re-loading the module in a live daemon re-runs the arming form, so a +non-idempotent start would stack a second ticker on every reload." + (let ((cj/--org-agenda-refresh-timer nil)) + (unwind-protect + (progn + (cj/org-agenda-auto-refresh-start) + (let ((first cj/--org-agenda-refresh-timer)) + (cj/org-agenda-auto-refresh-start) + (should (timerp cj/--org-agenda-refresh-timer)) + (should-not (memq first timer-list)) + (should (memq cj/--org-agenda-refresh-timer timer-list)))) + (cj/org-agenda-auto-refresh-stop)))) + +(ert-deftest test-org-agenda-config-auto-refresh-stop-clears-timer () + "Normal: stopping cancels the timer and clears the handle." + (let ((cj/--org-agenda-refresh-timer nil)) + (cj/org-agenda-auto-refresh-start) + (let ((timer cj/--org-agenda-refresh-timer)) + (cj/org-agenda-auto-refresh-stop) + (should-not cj/--org-agenda-refresh-timer) + (should-not (memq timer timer-list))))) + +(ert-deftest test-org-agenda-config-auto-refresh-stop-is-safe-when-stopped () + "Boundary: stopping an already-stopped refresh is a no-op, not an error." + (let ((cj/--org-agenda-refresh-timer nil)) + (should (progn (cj/org-agenda-auto-refresh-stop) t)) + (should-not cj/--org-agenda-refresh-timer))) + +(provide 'test-org-agenda-config--auto-refresh) +;;; test-org-agenda-config--auto-refresh.el ends here diff --git a/tests/test-org-agenda-config-category.el b/tests/test-org-agenda-config-category.el index 6a54d9e6..918d342a 100644 --- a/tests/test-org-agenda-config-category.el +++ b/tests/test-org-agenda-config-category.el @@ -88,12 +88,11 @@ Suppresses other org-mode hooks to keep the test isolated." (text-mode-hook nil)) (org-mode)) (setq buffer-file-name ,path) - ;; mimic org's default category (filename-sans-extension) so the - ;; hook's "only override the default" guard is exercised. - (setq-local org-category - (and ,path - (file-name-sans-extension - (file-name-nondirectory ,path)))) + ;; `org-category' is deliberately left nil, which is what org actually + ;; does with no `#+CATEGORY:'. An earlier version of this fixture set it + ;; to the filename base to "mimic org's default"; org never does that, so + ;; these tests passed against a state that cannot occur while the feature + ;; did nothing in practice. ,body-form)) ;;; Normal Cases @@ -106,11 +105,14 @@ Suppresses other org-mode hooks to keep the test isolated." (should (equal "emacs.d" org-category))))) (ert-deftest test-org-agenda-config-category-hook-normal-leaves-inbox-alone () - "Normal: hook leaves inbox.org's category at its filename default." + "Normal: hook declines on a non-todo file, leaving `org-category' unset. +Leaving it nil is the correct outcome, not a gap: `org-get-category' then +derives \"inbox\" from the filename, which is already a useful label. The +end-to-end test below checks that derivation on a real file." (test-org-agenda-config-category--with-file "/home/cjennings/sync/org/roam/inbox.org" (progn (cj/--org-set-todo-category) - (should (equal "inbox" org-category))))) + (should (null org-category))))) ;;; Boundary Cases @@ -133,5 +135,98 @@ Suppresses other org-mode hooks to keep the test isolated." ;; no error and no spurious mutation (should t))) +;;; ---------- End-to-end: a real file through the real hook ---------- +;; The fixture above sets `org-category' by hand to the filename base, to +;; "mimic org's default". Org does not do that: with no `#+CATEGORY:' it +;; leaves `org-category' nil and derives the fallback inside +;; `org-get-category' at read time. So those tests exercise a precondition +;; that never occurs, and passed while the feature did nothing in practice. +;; +;; These drive a real file on disk through `find-file-noselect' (which runs +;; `org-mode-hook' for real) and assert on `org-get-category', which is what +;; the agenda's %c column actually reads. + +(defmacro test-org-agenda-config-category--with-real-file (spec &rest body) + "Create FILE under a temp project dir and visit it, then run BODY. +SPEC is (VAR DIRNAME FILENAME CONTENT). VAR is bound to the live buffer." + (declare (indent 1)) + (let ((var (nth 0 spec)) (dirname (nth 1 spec)) + (filename (nth 2 spec)) (content (nth 3 spec))) + ;; The outer `unwind-protect' covers `find-file-noselect' itself, so a + ;; signal there still removes the temp tree rather than leaking it. + `(let* ((root (make-temp-file "cj-cat-" t)) + (project (expand-file-name ,dirname root)) + (path (expand-file-name ,filename project)) + (,var nil)) + (unwind-protect + (progn + (make-directory project t) + (with-temp-file path (insert ,content)) + (setq ,var (find-file-noselect path)) + ,@body) + (when (buffer-live-p ,var) + (with-current-buffer ,var (set-buffer-modified-p nil)) + (kill-buffer ,var)) + (delete-directory root t))))) + +(ert-deftest test-org-agenda-config-category-endtoend-todo-shows-project () + "Normal: visiting a project's todo.org makes the agenda show the project. +This is the whole point of the feature, and it is what the hand-built +fixture above could not check." + (test-org-agenda-config-category--with-real-file + (buffer "myproject" "todo.org" "* TODO a task\n") + (with-current-buffer buffer + (should (equal "myproject" (org-get-category (point-min))))))) + +(ert-deftest test-org-agenda-config-category-endtoend-explicit-category-wins () + "Boundary: an explicit `#+CATEGORY:' still beats the derived name. + +Note what this does and does not prove. It confirms the user-visible contract, +but not that the hook's guard is what enforces it: `org-element--get-category' +searches the buffer for `#+CATEGORY:' itself and returns that before consulting +`org-category', so the directive survives even with the guard deleted. The +guard's own job is covered by +`test-org-agenda-config-category-hook-boundary-respects-explicit'." + (test-org-agenda-config-category--with-real-file + (buffer "myproject" "todo.org" "#+CATEGORY: Personal\n* TODO a task\n") + (with-current-buffer buffer + (should (equal "Personal" (org-get-category (point-min))))))) + +(ert-deftest test-org-agenda-config-category-endtoend-survives-an-earlier-hook () + "Error: the override still lands when another hook reads the category first. + +`org-get-category' resolves a deferred `:CATEGORY' that the org-element cache +then holds. A hook running BEFORE ours that reads it freezes \"todo\" in that +cache, and our later `setq-local' becomes inert -- `org-category' reads correct +while the agenda still shows \"todo\". + +This is not hypothetical. `add-hook' prepends by default, so every hook added +after ours runs before it, and the live config already has three ahead of it. +The fix is the explicit depth on our `add-hook'; this test is what holds it +there." + (test-org-agenda-config-category--with-real-file + (buffer "projX" "todo.org" "* TODO a task\n") + (ignore buffer)) + ;; Re-visit with a nosy reader installed ahead of ours. + (let ((reader (lambda () (ignore (org-get-category (point-min)))))) + (unwind-protect + (progn + (add-hook 'org-mode-hook reader) + (test-org-agenda-config-category--with-real-file + (buffer "projX" "todo.org" "* TODO a task\n") + (with-current-buffer buffer + (should (equal "projX" (org-get-category (point-min))))))) + (remove-hook 'org-mode-hook reader)))) + +(ert-deftest test-org-agenda-config-category-endtoend-other-filename-untouched () + "Boundary: a distinctively-named file keeps its filename category. +Only todo.org is generic enough to be worth replacing. Files like +schedule.org or gcal.org already say something useful, and deriving from +the directory would collapse several of them onto one name." + (test-org-agenda-config-category--with-real-file + (buffer "data" "gcal.org" "* TODO an event\n") + (with-current-buffer buffer + (should (equal "gcal" (org-get-category (point-min))))))) + (provide 'test-org-agenda-config-category) ;;; test-org-agenda-config-category.el ends here diff --git a/tests/test-org-agenda-config-display.el b/tests/test-org-agenda-config-display.el index af4c7ea0..f039985d 100644 --- a/tests/test-org-agenda-config-display.el +++ b/tests/test-org-agenda-config-display.el @@ -2,6 +2,8 @@ ;;; Commentary: ;; Tests for the display-buffer rule used by the F8 org agenda view. +;; The agenda takes the whole frame; these pin that, and pin the two ways +;; it previously failed to (a fraction of the frame, or shrunk to fit). ;;; Code: @@ -10,39 +12,58 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'org-agenda-config) -(ert-deftest test-org-agenda-config-display-rule-uses-configured-height () - "Normal: the agenda display rule uses the configured frame fraction." - (let ((cj/org-agenda-window-height 0.75)) - (should (equal (cdr (assoc 'window-height - (cddr (cj/--org-agenda-display-rule)))) - 0.75)))) +(defun test-org-agenda-config-display--actions () + "Return the display-action function list from the agenda rule." + (car (cdr (cj/--org-agenda-display-rule)))) + +(defun test-org-agenda-config-display--alist () + "Return the action alist from the agenda rule." + (cddr (cj/--org-agenda-display-rule))) + +(ert-deftest test-org-agenda-config-display-rule-takes-full-frame () + "Normal: the agenda display rule claims the whole frame." + (should (memq 'display-buffer-full-frame + (test-org-agenda-config-display--actions)))) + +(ert-deftest test-org-agenda-config-display-rule-reuses-agenda-window () + "Normal: an agenda already on screen is reused rather than re-displayed." + (should (memq 'display-buffer-reuse-mode-window + (test-org-agenda-config-display--actions)))) + +(ert-deftest test-org-agenda-config-display-rule-sets-no-window-height () + "Regression: no height fraction survives. +The rule used to hand the agenda 0.75 of the frame; a leftover +`window-height' entry would cap the full-frame window right back down." + (should-not (assoc 'window-height (test-org-agenda-config-display--alist)))) (ert-deftest test-org-agenda-config-display-rule-does-not-fit-to-buffer () "Regression: F8 agenda should not shrink to fit compact agenda contents." - (let ((cj/org-agenda-window-height 0.75)) - (should-not (eq (cdr (assoc 'window-height - (cddr (cj/--org-agenda-display-rule)))) - 'fit-window-to-buffer)))) - -(ert-deftest test-org-agenda-config-display-rule-creates-large-window () - "Integration: the agenda rule creates a window near the configured height." - (let ((cj/org-agenda-window-height 0.75) - (display-buffer-alist (list (cj/--org-agenda-display-rule))) + (should-not (eq (cdr (assoc 'window-height + (test-org-agenda-config-display--alist))) + 'fit-window-to-buffer))) + +(ert-deftest test-org-agenda-config-display-rule-window-not-dedicated () + "Regression: the agenda window must not be dedicated. +With the agenda owning the only window, a dedicated one leaves RET on an +item (`org-agenda-switch-to') nowhere to put the file, so it splits or +opens a frame instead of replacing the agenda." + (should-not (cdr (assoc 'dedicated (test-org-agenda-config-display--alist))))) + +(ert-deftest test-org-agenda-config-display-rule-creates-sole-window () + "Integration: displaying the agenda leaves it as the frame's only window." + (let ((display-buffer-alist (list (cj/--org-agenda-display-rule))) (buffer (get-buffer-create "*Org Agenda*"))) (unwind-protect (save-window-excursion (delete-other-windows) + (split-window-below) (with-current-buffer buffer (erase-buffer) - (dotimes (_ 3) - (insert "agenda line\n"))) - (let* ((before-height (window-total-height)) - (window (display-buffer buffer)) - (actual-ratio (/ (float (window-total-height window)) - before-height))) - (should (= 2 (length (window-list)))) - (should (> actual-ratio 0.65)) - (should (< actual-ratio 0.85)))) + (dotimes (_ 3) (insert "agenda line\n"))) + (let ((window (display-buffer buffer))) + (should (= 1 (length (window-list)))) + (should (eq window (car (window-list)))) + (should (eq (window-buffer window) buffer)))) (kill-buffer buffer)))) (provide 'test-org-agenda-config-display) diff --git a/tests/test-org-agenda-frame.el b/tests/test-org-agenda-frame.el deleted file mode 100644 index 3c56d361..00000000 --- a/tests/test-org-agenda-frame.el +++ /dev/null @@ -1,1104 +0,0 @@ -;;; test-org-agenda-frame.el --- Tests for the fullscreen agenda frame -*- lexical-binding: t; -*- - -;;; Commentary: -;; Phase 1 of the org-agenda fullscreen frame (spec: -;; docs/specs/2026-07-17-org-agenda-fullscreen-frame-spec.org). Frame lookup -;; is mocked (frame-list / frame-live-p / frame-parameter), the house pattern -;; from test-dirvish-config-popup.el, since --batch can't create real frames. - -;;; Code: - -(require 'ert) -(require 'cl-lib) - -(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) -(require 'org-agenda-frame) - -;; org-agenda isn't loaded in batch (no package-initialize), so declare the -;; command list special and bound for the registration tests to let-bind. -(defvar org-agenda-custom-commands nil) - -;;; cj/--agenda-frame — locate the marked frame - -(ert-deftest test-org-agenda-frame-find-returns-marked-live-frame () - "Normal: returns the live frame carrying the `cj/agenda-frame' marker." - (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fb fc))) - ((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'frame-parameter) - (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'fb))))) - (should (eq (cj/--agenda-frame) 'fb)))) - -(ert-deftest test-org-agenda-frame-find-nil-when-none-marked () - "Boundary: no frame carries the marker -> nil." - (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fc))) - ((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'frame-parameter) (lambda (_f _p) nil))) - (should (null (cj/--agenda-frame))))) - -(ert-deftest test-org-agenda-frame-find-ignores-dead-marked-frame () - "Error: a marked but dead frame is not returned." - (cl-letf (((symbol-function 'frame-list) (lambda () '(fa fb))) - ((symbol-function 'frame-live-p) (lambda (f) (not (eq f 'fb)))) - ((symbol-function 'frame-parameter) - (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'fb))))) - (should (null (cj/--agenda-frame))))) - -;;; cj/--agenda-frame-p — is FRAME a live agenda frame - -(ert-deftest test-org-agenda-frame-p-true-for-live-marked () - "Normal: a live marked frame is an agenda frame." - (cl-letf (((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'frame-parameter) - (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'fa))))) - (should (cj/--agenda-frame-p 'fa)))) - -(ert-deftest test-org-agenda-frame-p-nil-for-unmarked () - "Boundary: a live unmarked frame is not an agenda frame." - (cl-letf (((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'frame-parameter) (lambda (_f _p) nil))) - (should (null (cj/--agenda-frame-p 'fa))))) - -(ert-deftest test-org-agenda-frame-p-nil-for-dead-marked () - "Error: a dead marked frame is not an agenda frame." - (cl-letf (((symbol-function 'frame-live-p) (lambda (_f) nil)) - ((symbol-function 'frame-parameter) - (lambda (_f p) (eq p 'cj/agenda-frame)))) - (should (null (cj/--agenda-frame-p 'fa))))) - -;;; cj/--agenda-frame-working-frame — route source files to a non-agenda frame - -(ert-deftest test-org-agenda-working-frame-returns-non-agenda-frame () - "Normal: with no recorded launch frame, returns the first live non-agenda frame." - (let ((cj/--agenda-frame-launch-frame nil)) - (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda work))) - ((symbol-function 'frame-live-p) (lambda (f) (memq f '(agenda work)))) - ((symbol-function 'frame-parameter) - (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) - (should (eq (cj/--agenda-frame-working-frame) 'work))))) - -(ert-deftest test-org-agenda-working-frame-prefers-live-launch-frame () - "Normal: the recorded launch frame wins when live and non-agenda." - (let ((cj/--agenda-frame-launch-frame 'w2)) - (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda w1 w2))) - ((symbol-function 'frame-live-p) (lambda (f) (memq f '(agenda w1 w2)))) - ((symbol-function 'frame-parameter) - (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) - (should (eq (cj/--agenda-frame-working-frame) 'w2))))) - -(ert-deftest test-org-agenda-working-frame-falls-back-when-launch-dead () - "Boundary: a dead recorded launch frame falls back to another non-agenda frame." - (let ((cj/--agenda-frame-launch-frame 'gone)) - (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda work))) - ((symbol-function 'frame-live-p) (lambda (f) (memq f '(agenda work)))) - ((symbol-function 'frame-parameter) - (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) - (should (eq (cj/--agenda-frame-working-frame) 'work))))) - -(ert-deftest test-org-agenda-working-frame-nil-when-only-agenda () - "Error: the agenda frame is the only live frame -> nil (caller creates one)." - (let ((cj/--agenda-frame-launch-frame nil)) - (cl-letf (((symbol-function 'frame-list) (lambda () '(agenda))) - ((symbol-function 'frame-live-p) (lambda (f) (eq f 'agenda))) - ((symbol-function 'frame-parameter) - (lambda (f p) (and (eq p 'cj/agenda-frame) (eq f 'agenda))))) - (should (null (cj/--agenda-frame-working-frame)))))) - -;;; cj/--agenda-frame-command — the dedicated F seven-day view - -(defun test-org-agenda-frame--block-settings () - "Return the per-block settings alist of the agenda-frame command." - (let* ((cmd (cj/--agenda-frame-command)) - (blocks (nth 2 cmd)) - (agenda-block (car blocks))) - (nth 2 agenda-block))) - -(defun test-org-agenda-frame--general-settings () - "Return the general (view-wide) settings alist of the agenda-frame command." - (nth 3 (cj/--agenda-frame-command))) - -(ert-deftest test-org-agenda-frame-command-key-is-F () - "Normal: the command's key is F (collision-free with the existing d)." - (should (equal (nth 0 (cj/--agenda-frame-command)) "F"))) - -(ert-deftest test-org-agenda-frame-command-today-anchored-7-day () - "Normal: the default span is seven days anchored to today, not Monday. -The span is the frame-span variable (default 7), evaluated the way org -evaluates custom-command settings." - (let ((s (test-org-agenda-frame--block-settings))) - (should (equal (default-value 'cj/--agenda-frame-span) 7)) - (should (equal (eval (cadr (assq 'org-agenda-span s)) t) - (default-value 'cj/--agenda-frame-span))) - (should (equal (cadr (assq 'org-agenda-start-day s)) "0d")) - ;; start-on-weekday nil is what un-anchors the span from Monday. - (should (assq 'org-agenda-start-on-weekday s)) - (should (null (cadr (assq 'org-agenda-start-on-weekday s)))))) - -(ert-deftest test-org-agenda-frame-command-span-follows-variable () - "Normal: the block span reads `cj/--agenda-frame-span', so d/w can change it -and a redo -- which re-evaluates the lprops -- picks up the new span." - (let ((cj/--agenda-frame-span 1)) - (should (equal (eval (cadr (assq 'org-agenda-span - (test-org-agenda-frame--block-settings))) - t) - 1))) - (let ((cj/--agenda-frame-span 7)) - (should (equal (eval (cadr (assq 'org-agenda-span - (test-org-agenda-frame--block-settings))) - t) - 7)))) - -(ert-deftest test-org-agenda-frame-day-view-sets-span-1-and-redoes () - "Normal: d sets the span to one day and refreshes via the safe redo." - (let ((cj/--agenda-frame-span 7) redone) - (cl-letf (((symbol-function 'cj/--agenda-frame-safe-redo) - (lambda (&rest _) (setq redone t)))) - (cj/--agenda-frame-day-view) - (should (equal cj/--agenda-frame-span 1)) - (should redone)))) - -(ert-deftest test-org-agenda-frame-week-view-sets-span-7-and-redoes () - "Normal: w restores the seven-day span and refreshes." - (let ((cj/--agenda-frame-span 1) redone) - (cl-letf (((symbol-function 'cj/--agenda-frame-safe-redo) - (lambda (&rest _) (setq redone t)))) - (cj/--agenda-frame-week-view) - (should (equal cj/--agenda-frame-span 7)) - (should redone)))) - -(ert-deftest test-org-agenda-frame-command-tight-prefix-format () - "Normal: the view sets its own prefix format with a narrow category column. -Without it the global agenda format applies, whose 25-char category pad -leaves a wide blank gutter between the source name and the item." - (let ((s (test-org-agenda-frame--block-settings))) - (should (assq 'org-agenda-prefix-format s)) - (should (string-match-p "%-10:c" - (cadr (assq 'org-agenda-prefix-format s)))))) - -(ert-deftest test-org-agenda-frame-do-redo-leaves-sticky-alone () - "Normal: the redo binds current-window but never touches sticky. -org-agenda-redo handles the in-place rebuild itself (it binds sticky nil -and redirects the buffer name); a sticky t reaching org-agenda-prepare -mid-redo makes it throw \\='exit with no catch and the tick fails." - (let ((org-agenda-sticky nil) - seen-sticky seen-setup (params '())) - (with-temp-buffer - (insert "agenda line\n") - (cl-letf (((symbol-function 'org-agenda-redo) - (lambda (&rest _) - (setq seen-sticky org-agenda-sticky - seen-setup org-agenda-window-setup))) - ((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) - ((symbol-function 'set-frame-parameter) - (lambda (_f p v) (setf (alist-get p params) v)))) - (cj/--agenda-frame-do-redo 'af (current-buffer) nil) - (should (null seen-sticky)) - (should (eq seen-setup 'current-window)))))) - -(ert-deftest test-org-agenda-frame-command-follow-mode-off () - "Boundary: follow-mode is forced off locally so a global default can't split." - (let ((s (test-org-agenda-frame--block-settings))) - (should (assq 'org-agenda-start-with-follow-mode s)) - (should (null (cadr (assq 'org-agenda-start-with-follow-mode s)))))) - -(ert-deftest test-org-agenda-frame-command-sticky-and-current-window () - "Normal: current-window in the settings; sticky deliberately NOT there. -The general settings are baked into the buffer's series-redo-cmd and -re-applied on every redo; a sticky t there makes org-agenda-use-sticky-p -true mid-redo (the buffer exists), and org-agenda-prepare throws \\='exit -with no catch -- every refresh tick fails. Stickiness belongs only in -the spawn wrapper, where it names the buffer." - (let ((g (test-org-agenda-frame--general-settings))) - (should-not (assq 'org-agenda-sticky g)) - ;; org evaluates custom-command setting values via org-let, so the stored - ;; form is (quote current-window); eval it the way org would. - (should (eq (eval (cadr (assq 'org-agenda-window-setup g)) t) - 'current-window)))) - -;;; cj/--agenda-frame-register-command — idempotent registration - -(ert-deftest test-org-agenda-frame-register-adds-entry () - "Normal: registration inserts the F entry into org-agenda-custom-commands." - (let ((org-agenda-custom-commands '(("d" "Daily" nil)))) - (cj/--agenda-frame-register-command) - (should (assoc "F" org-agenda-custom-commands)) - (should (assoc "d" org-agenda-custom-commands)))) - -(ert-deftest test-org-agenda-frame-register-is-idempotent () - "Boundary: registering twice leaves exactly one F entry." - (let ((org-agenda-custom-commands nil)) - (cj/--agenda-frame-register-command) - (cj/--agenda-frame-register-command) - (should (= 1 (seq-count (lambda (e) (equal (car e) "F")) - org-agenda-custom-commands))))) - -;;; Default-deny policy — denial handlers - -(ert-deftest test-org-agenda-frame-denied-readonly-messages () - "Normal: the read-only denial shows the read-only message and acts on nothing." - (let (captured) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) - (cj/--agenda-frame-denied-readonly)) - (should (string-match-p "read-only" captured)) - (should (string-match-p "working frame" captured)))) - -(ert-deftest test-org-agenda-frame-denied-fixed-view-messages () - "Normal: the view-change denial shows the fixed-view message." - (let (captured) - (cl-letf (((symbol-function 'message) - (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) - (cj/--agenda-frame-denied-fixed-view)) - (should (string-match-p "day (d) and week (w)" captured)))) - -;;; Default-deny policy — the keymap - -(ert-deftest test-org-agenda-frame-map-catch-all-is-readonly-deny () - "Normal: the [t] default binding denies with the read-only handler." - (should (eq (lookup-key cj/agenda-frame-mode-map [t]) - 'cj/--agenda-frame-denied-readonly))) - -(ert-deftest test-org-agenda-frame-map-navigation-allowed () - "Normal: navigation keys resolve to their org-agenda commands." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "n")) 'org-agenda-next-line)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "p")) 'org-agenda-previous-line)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-g")) 'keyboard-quit))) - -(ert-deftest test-org-agenda-frame-map-point-motion-and-isearch-allowed () - "Normal: read-only point motion and isearch work in the frame. -C-a/C-e/C-f/C-b move point and C-s/C-r search; all are read-only and -must not hit the deny catch-all." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-a")) 'move-beginning-of-line)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-e")) 'move-end-of-line)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-f")) 'forward-char)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-b")) 'backward-char)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-s")) 'isearch-forward)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-r")) 'isearch-backward))) - -(ert-deftest test-org-agenda-frame-map-engage-routed () - "Normal: RET and TAB route to the working-frame engage command." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "RET")) - 'cj/--agenda-frame-engage-open)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "TAB")) - 'cj/--agenda-frame-engage-open))) - -(ert-deftest test-org-agenda-frame-map-engage-gui-function-keys () - "Boundary: the GUI [return]/[tab] events engage too, not the [t] deny handler. -Without these, the catch-all suppresses their translation to RET/TAB in a -graphical frame and RET would be denied instead of opening the item." - (should (eq (lookup-key cj/agenda-frame-mode-map [return]) - 'cj/--agenda-frame-engage-open)) - (should (eq (lookup-key cj/agenda-frame-mode-map [tab]) - 'cj/--agenda-frame-engage-open))) - -(ert-deftest test-org-agenda-frame-map-lifecycle-keys () - "Normal: q/Q/x close the frame; r and g take the safe-redo path. -g is the muscle-memory agenda refresh; it must refresh, not hit the -fixed-view deny handler." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "q")) 'cj/--agenda-frame-close)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "Q")) 'cj/--agenda-frame-close)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "x")) 'cj/--agenda-frame-close)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "r")) 'cj/--agenda-frame-safe-redo)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "g")) 'cj/--agenda-frame-safe-redo))) - -(ert-deftest test-org-agenda-frame-map-view-changers-fixed-view-deny () - "Boundary: view-changing keys are explicitly denied with the fixed-view message, -not caught by the read-only catch-all." - (dolist (key '("y" "f" "b" "j")) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd key)) - 'cj/--agenda-frame-denied-fixed-view)))) - -(ert-deftest test-org-agenda-frame-map-day-week-view-keys () - "Normal: d and w toggle the span (day / week) rather than being denied. -d shrinks the frame to the current day, w restores the seven-day span." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "d")) - 'cj/--agenda-frame-day-view)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "w")) - 'cj/--agenda-frame-week-view))) - -(ert-deftest test-org-agenda-frame-shadow-denies-org-mutations-preserves-allowlist () - "Boundary: with the frame mode active over `org-agenda-mode-map', mutating -org-agenda keys are denied and the allowlist still works. -The `[t]' default cannot shadow org-agenda-mode-map's explicit bindings, so -the shadow walk must add explicit denies for every non-allowlisted key -- -single keys (t/I/k/z/s/.), the C-c mutators (schedule/deadline/clock), and -C-x (save-all) -- while leaving the allowlist (navigation, engage, refresh, -d/w, C-c C-o) intact." - (require 'org-agenda) - (cj/--agenda-frame-shadow-mutations) - (with-temp-buffer - (use-local-map org-agenda-mode-map) - (cj/agenda-frame-mode 1) - ;; escaping mutators are now explicitly denied (not org's commands) - (dolist (chord '("t" "I" "k" "z" "s" "." "C-c C-s" "C-c C-d" - "C-c C-x C-i" "C-x C-s")) - (should (eq (key-binding (kbd chord)) - 'cj/--agenda-frame-denied-readonly))) - ;; the allowlist survives the walk - (should (eq (key-binding (kbd "n")) 'org-agenda-next-line)) - (should (eq (key-binding (kbd "p")) 'org-agenda-previous-line)) - (should (eq (key-binding (kbd "RET")) 'cj/--agenda-frame-engage-open)) - (should (eq (key-binding (kbd "g")) 'cj/--agenda-frame-safe-redo)) - (should (eq (key-binding (kbd "d")) 'cj/--agenda-frame-day-view)) - (should (eq (key-binding (kbd "w")) 'cj/--agenda-frame-week-view)) - (should (eq (key-binding (kbd "C-c C-o")) 'cj/--agenda-frame-open-link)) - (should (eq (key-binding (kbd "q")) 'cj/--agenda-frame-close)))) - -(ert-deftest test-org-agenda-frame-map-frame-controls-bound () - "Normal: the frame's own controls work from inside the frame. -S-<f8> must close/toggle and C-M-<f8> must force-rescan; unbound, the -catch-all denies them and the frame can't be closed by its own key." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "S-<f8>")) - 'cj/agenda-frame-toggle)) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-M-<f8>")) - 'cj/org-agenda-refresh-files))) - -(ert-deftest test-org-agenda-frame-map-C-x-C-c-closes-frame () - "Normal: C-x C-c in the agenda frame closes the frame, not the daemon. -The global save-buffers-kill-terminal would kill Emacs itself here (a -make-frame frame has no client), so the intuitive close gesture must be -remapped to the frame close." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "C-x C-c")) - 'cj/--agenda-frame-close))) - -(ert-deftest test-org-agenda-frame-map-machinery-punched-through () - "Boundary: input machinery is punched through the [t] catch-all. -switch-frame events, mouse-wheel scrolling, mouse-1 clicks, and the help -prefix must fall through to their global bindings (an explicit nil shadows -the default in this map); otherwise every frame-focus change and every -scroll spams the deny message." - (dolist (key (list [switch-frame] - [wheel-up] [wheel-down] [wheel-left] [wheel-right] - [double-wheel-up] [double-wheel-down] - [triple-wheel-up] [triple-wheel-down] - [mouse-1] [down-mouse-1] [drag-mouse-1] - (kbd "C-h"))) - ;; accept-default t: a punched key returns nil (falls through to the - ;; global map); an unpunched key returns the catch-all deny handler. - (should (null (lookup-key cj/agenda-frame-mode-map key t))))) - -(ert-deftest test-org-agenda-frame-map-global-escape-chords-denied () - "Boundary: global chords bound elsewhere (M-SPC / M-S-SPC swap ai-term -agents) are denied by an explicit binding, not left to the [t] catch-all. -A keymap's default binding does not shadow an explicit binding in a -lower-priority map, so without an explicit deny here M-SPC follows its -global binding and escapes the read-only frame into ai-term." - (dolist (key '("M-SPC" "M-S-SPC")) - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd key)) - 'cj/--agenda-frame-denied-readonly)))) - -(ert-deftest test-org-agenda-frame-map-unpunched-still-denied () - "Normal: an ordinary unbound key still hits the catch-all after the punches." - (should (eq (lookup-key cj/agenda-frame-mode-map (kbd "t") t) - 'cj/--agenda-frame-denied-readonly))) - -(ert-deftest test-org-agenda-frame-maybe-enable-readds-kill-buffer-hook () - "Normal: the finalize re-enable also re-adds the buffer-local kill hook. -org-agenda-redo's kill-all-local-variables strips the hook installed at -spawn; without the re-add, killing the buffer after the first refresh tick -orphans the frame." - (with-temp-buffer - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'agenda)) - ((symbol-function 'get-buffer-window) (lambda (_b _f) 'win))) - (cj/--agenda-frame-maybe-enable-mode) - (should (memq 'cj/--agenda-frame-on-kill-buffer - (buffer-local-value 'kill-buffer-hook (current-buffer))))))) - -(ert-deftest test-org-agenda-frame-overlay-removable-after-local-var-wipe () - "Error: the failure overlay is found by property, not a buffer-local var. -kill-all-local-variables (every redo) wipes buffer-local vars while the -overlay object survives erase-buffer, so a var-held overlay could never be -removed after a later success -- the failure banner would stick forever." - (with-temp-buffer - (insert "x\n") - (cj/--agenda-frame-show-failure-overlay (current-buffer)) - ;; Simulate the org-agenda-mode reset between failure and success. - (kill-all-local-variables) - (cj/--agenda-frame-remove-overlay (current-buffer)) - ;; The visible banner (a before-string overlay) must be gone. - (should (= 0 (seq-count (lambda (o) (overlay-get o 'before-string)) - (overlays-in (point-min) (point-max))))))) - -(ert-deftest test-org-agenda-frame-map-mutation-keys-denied () - "Boundary: a mutation key (t = org-agenda-todo) is denied, never allowlisted. -It is denied two ways depending on whether the shadow walk has run: the `[t]' -catch-all handles it (lookup returns nil) before the walk, and the walk binds -it explicitly to the deny handler once `org-agenda-mode-map' is present. Both -are a read-only denial; the test asserts the outcome, not which path produced -it, so it holds whether or not org-agenda is loaded in the test process." - (let ((b (lookup-key cj/agenda-frame-mode-map (kbd "t")))) - (should (or (null b) (eq b 'cj/--agenda-frame-denied-readonly))))) - -;;; Default-deny policy — the minor mode + finalize re-enable - -(ert-deftest test-org-agenda-frame-mode-toggles () - "Normal: the minor mode turns on and off in a buffer." - (with-temp-buffer - (cj/agenda-frame-mode 1) - (should cj/agenda-frame-mode) - (cj/agenda-frame-mode -1) - (should-not cj/agenda-frame-mode))) - -(ert-deftest test-org-agenda-frame-maybe-enable-in-agenda-frame () - "Normal: after a build in the agenda frame, the policy is re-enabled." - (with-temp-buffer - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'agenda)) - ((symbol-function 'get-buffer-window) (lambda (_b _f) 'win))) - (cj/--agenda-frame-maybe-enable-mode) - (should cj/agenda-frame-mode)))) - -(ert-deftest test-org-agenda-frame-maybe-enable-skips-other-buffers () - "Boundary: a build not shown in the agenda frame leaves the policy off." - (with-temp-buffer - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'agenda)) - ((symbol-function 'get-buffer-window) (lambda (_b _f) nil))) - (cj/--agenda-frame-maybe-enable-mode) - (should-not cj/agenda-frame-mode)))) - -(ert-deftest test-org-agenda-frame-maybe-enable-no-frame () - "Boundary: no agenda frame at all -> policy stays off, no error." - (with-temp-buffer - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil))) - (cj/--agenda-frame-maybe-enable-mode) - (should-not cj/agenda-frame-mode)))) - -;;; Engage routing — frame target + open - -(ert-deftest test-org-agenda-frame-target-frame-uses-working-frame () - "Normal: the engage target is the working frame when one exists." - (cl-letf (((symbol-function 'cj/--agenda-frame-working-frame) (lambda () 'work)) - ((symbol-function 'make-frame) (lambda (&rest _) (error "should not create")))) - (should (eq (cj/--agenda-frame-target-frame) 'work)))) - -(ert-deftest test-org-agenda-frame-target-frame-creates-when-none () - "Boundary: no working frame -> a normal frame is created." - (cl-letf (((symbol-function 'cj/--agenda-frame-working-frame) (lambda () nil)) - ((symbol-function 'make-frame) (lambda (&rest _) 'new))) - (should (eq (cj/--agenda-frame-target-frame) 'new)))) - -(ert-deftest test-org-agenda-frame-engage-open-no-item-errors () - "Error: engaging on a line with no source item signals a user-error." - (cl-letf (((symbol-function 'cj/--agenda-frame-item-marker) (lambda () nil))) - (should-error (cj/--agenda-frame-engage-open) :type 'user-error))) - -(ert-deftest test-org-agenda-frame-engage-open-routes-to-source () - "Normal: engage opens the item's source buffer at the item's position." - (let ((source (generate-new-buffer " *frame-engage-source*"))) - (unwind-protect - (progn - (with-current-buffer source (insert "line one\nline two\nline three\n")) - (let ((marker (set-marker (make-marker) 10 source)) - focused opened) - (cl-letf (((symbol-function 'cj/--agenda-frame-item-marker) (lambda () marker)) - ((symbol-function 'cj/--agenda-frame-target-frame) (lambda () 'work)) - ((symbol-function 'select-frame-set-input-focus) - (lambda (f &rest _) (setq focused f))) - ((symbol-function 'pop-to-buffer-same-window) - (lambda (b &rest _) (setq opened b) (set-buffer b))) - ((symbol-function 'org-fold-show-context) (lambda (&rest _) nil))) - (cj/--agenda-frame-engage-open) - (should (eq focused 'work)) - (should (eq opened source)) - (should (eq (current-buffer) source)) - (should (= (point) (line-beginning-position)))))) - (kill-buffer source)))) - -;;; Frame lifecycle — sticky buffer, timer-cancel, teardown cleanup - -(ert-deftest test-org-agenda-frame-sticky-buffer-name () - "Normal: the sticky buffer is *Org Agenda(F)*; nil when absent." - (should (null (cj/--agenda-frame-sticky-buffer))) - (let ((buf (get-buffer-create "*Org Agenda(F)*"))) - (unwind-protect - (should (eq (cj/--agenda-frame-sticky-buffer) buf)) - (kill-buffer buf)))) - -(ert-deftest test-org-agenda-frame-cancel-timer-safe-when-none () - "Boundary: cancelling with no timer set does nothing and does not error." - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil))) - (should-not (cj/--agenda-frame-cancel-timer)))) - -;;; Frame lifecycle — toggle dispatch - -(ert-deftest test-org-agenda-frame-toggle-spawns-when-none () - "Normal: with no agenda frame, toggle spawns one." - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil)) - ((symbol-function 'cj/--agenda-frame-spawn) (lambda () 'spawned))) - (should (eq (cj/--agenda-frame-toggle) 'spawned)))) - -(ert-deftest test-org-agenda-frame-toggle-deletes-when-selected () - "Normal: toggle from within the agenda frame deletes it." - (let (deleted) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'selected-frame) (lambda () 'af)) - ((symbol-function 'cj/--agenda-frame-delete) - (lambda () (setq deleted t)))) - (cj/--agenda-frame-toggle) - (should deleted)))) - -(ert-deftest test-org-agenda-frame-toggle-raises-when-unfocused () - "Normal: toggle from a working frame raises the existing agenda frame." - (let (raised) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'selected-frame) (lambda () 'work)) - ((symbol-function 'cj/--agenda-frame-raise) - (lambda (f) (setq raised f)))) - (cj/--agenda-frame-toggle) - (should (eq raised 'af))))) - -;;; Frame lifecycle — delete - -(ert-deftest test-org-agenda-frame-delete-deletes-live-frame () - "Normal: delete removes the live agenda frame." - (let (deleted) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'frame-live-p) (lambda (f) (eq f 'af))) - ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) - (cj/--agenda-frame-delete) - (should (eq deleted 'af))))) - -(ert-deftest test-org-agenda-frame-delete-noop-when-none () - "Boundary: delete with no agenda frame does nothing." - (let (called) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () nil)) - ((symbol-function 'delete-frame) (lambda (_f &rest _) (setq called t)))) - (cj/--agenda-frame-delete) - (should-not called)))) - -;;; Frame lifecycle — cleanup on frame death and buffer kill - -(ert-deftest test-org-agenda-frame-on-delete-cancels-and-kills-buffer () - "Normal: deleting the agenda frame cancels its timer and kills the sticky buffer." - (let ((buf (get-buffer-create "*Org Agenda(F)*")) - cancelled) - (unwind-protect - (cl-letf (((symbol-function 'cj/--agenda-frame-p) (lambda (_f) t)) - ((symbol-function 'cj/--agenda-frame-cancel-timer) - (lambda (&optional _f) (setq cancelled t)))) - (cj/--agenda-frame-on-delete-frame 'af) - (should cancelled) - (should-not (buffer-live-p buf))) - (when (buffer-live-p buf) (kill-buffer buf))))) - -(ert-deftest test-org-agenda-frame-on-delete-ignores-non-agenda-frame () - "Boundary: a non-agenda frame deletion triggers no cleanup." - (let (cancelled) - (cl-letf (((symbol-function 'cj/--agenda-frame-p) (lambda (_f) nil)) - ((symbol-function 'cj/--agenda-frame-cancel-timer) - (lambda (&optional _f) (setq cancelled t)))) - (cj/--agenda-frame-on-delete-frame 'work) - (should-not cancelled)))) - -(ert-deftest test-org-agenda-frame-on-kill-buffer-deletes-frame () - "Normal: killing the dedicated buffer deletes the frame." - (let (deleted) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'frame-live-p) (lambda (f) (eq f 'af))) - ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) - (cj/--agenda-frame-on-kill-buffer) - (should (eq deleted 'af))))) - -(ert-deftest test-org-agenda-frame-on-kill-buffer-guarded-during-teardown () - "Boundary: during a teardown the buffer-kill hook does not re-delete the frame." - (let (deleted (cj/--agenda-frame-tearing-down t)) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) - (cj/--agenda-frame-on-kill-buffer) - (should-not deleted)))) - -;;; Auto-dim suspension while the agenda frame lives - -(ert-deftest test-org-agenda-frame-spawn-suspends-auto-dim () - "Normal: spawning the frame turns auto-dim off and remembers it was on. -The refresh tick's selection swing marks the working window non-selected; -auto-dim's debounced dim then lands after the tick and the working frame -visibly dims every five minutes." - (defvar auto-dim-other-buffers-mode) - (let ((auto-dim-other-buffers-mode t) - (cj/--agenda-frame-dim-was-on nil) - calls) - (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) - (lambda (arg) (push arg calls))) - ((symbol-function 'selected-frame) (lambda () 'launch)) - ((symbol-function 'make-frame) (lambda (&rest _) 'af)) - ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) - ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) - ((symbol-function 'org-agenda) (lambda (&rest _) nil)) - ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) - ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) - (cj/--agenda-frame-spawn) - (should (equal calls '(-1))) - (should cj/--agenda-frame-dim-was-on)))) - -(ert-deftest test-org-agenda-frame-spawn-leaves-auto-dim-when-off () - "Boundary: auto-dim already off -> spawn doesn't touch it, no restore later." - (defvar auto-dim-other-buffers-mode) - (let ((auto-dim-other-buffers-mode nil) - (cj/--agenda-frame-dim-was-on nil) - calls) - (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) - (lambda (arg) (push arg calls))) - ((symbol-function 'selected-frame) (lambda () 'launch)) - ((symbol-function 'make-frame) (lambda (&rest _) 'af)) - ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) - ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) - ((symbol-function 'org-agenda) (lambda (&rest _) nil)) - ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) - ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) - (cj/--agenda-frame-spawn) - (should (null calls)) - (should-not cj/--agenda-frame-dim-was-on)))) - -(ert-deftest test-org-agenda-frame-on-delete-restores-auto-dim () - "Normal: closing the frame restores auto-dim when spawn had turned it off." - (let ((cj/--agenda-frame-dim-was-on t) - calls) - (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) - (lambda (arg) (push arg calls))) - ((symbol-function 'cj/--agenda-frame-p) (lambda (_f) t)) - ((symbol-function 'cj/--agenda-frame-cancel-timer) - (lambda (&optional _f) nil))) - (cj/--agenda-frame-on-delete-frame 'af) - (should (equal calls '(1))) - (should-not cj/--agenda-frame-dim-was-on)))) - -(ert-deftest test-org-agenda-frame-on-delete-no-dim-restore-when-untouched () - "Boundary: closing without a suspended auto-dim doesn't enable it." - (let ((cj/--agenda-frame-dim-was-on nil) - calls) - (cl-letf (((symbol-function 'auto-dim-other-buffers-mode) - (lambda (arg) (push arg calls))) - ((symbol-function 'cj/--agenda-frame-p) (lambda (_f) t)) - ((symbol-function 'cj/--agenda-frame-cancel-timer) - (lambda (&optional _f) nil))) - (cj/--agenda-frame-on-delete-frame 'af) - (should (null calls))))) - -;;; Frame lifecycle — transactional spawn rollback - -(ert-deftest test-org-agenda-frame-spawn-rolls-back-on-failure () - "Error: a failure after make-frame deletes the partial frame, restores the -working frame, and signals a user-error." - (let (deleted focus) - (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) - ((symbol-function 'make-frame) (lambda (&rest _) 'pf)) - ((symbol-function 'select-frame-set-input-focus) - (lambda (f &rest _) (setq focus f))) - ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) - ((symbol-function 'org-agenda) (lambda (&rest _) (error "boom"))) - ((symbol-function 'frame-live-p) (lambda (f) (memq f '(pf launch)))) - ((symbol-function 'delete-frame) (lambda (f &rest _) (setq deleted f)))) - (should-error (cj/--agenda-frame-spawn) :type 'user-error) - (should (eq deleted 'pf)) - (should (eq focus 'launch))))) - -;;; Phase 2 — wall-clock alignment - -(ert-deftest test-org-agenda-frame-seconds-to-next-mark-aligned () - "Normal: a time exactly on a 5-minute boundary yields a full period." - ;; 1000000200 is divisible by 300 (a :00/:05 wall-clock mark). - (should (= (cj/--agenda-frame-seconds-to-next-mark 1000000200 300) 300))) - -(ert-deftest test-org-agenda-frame-seconds-to-next-mark-midway () - "Boundary: partway through a period returns the remainder to the next mark." - ;; 1000000200 + 120 -> 180 seconds remain to the next 300 mark. - (should (= (cj/--agenda-frame-seconds-to-next-mark 1000000320 300) 180))) - -;;; Phase 2 — deterministic point restoration - -(defun test-org-agenda-frame--make-agenda-buffer (lines source) - "Insert LINES into the current buffer; each is (TEXT . SRC-POS). -A non-nil SRC-POS puts an org-marker into SOURCE at that position on the line." - (dolist (spec lines) - (let ((start (point))) - (insert (car spec) "\n") - (when (cdr spec) - (put-text-property start (1+ start) 'org-marker - (set-marker (make-marker) (cdr spec) source)))))) - -(ert-deftest test-org-agenda-frame-restore-point-duplicate-nearest () - "Normal: a source marker occurring twice restores the occurrence nearest the old line." - (let ((src (generate-new-buffer " *rp-src*"))) - (unwind-protect - (with-temp-buffer - (with-current-buffer src (insert "aaaaaaaaaa\n")) - (test-org-agenda-frame--make-agenda-buffer - '(("header" . nil) ("item @2" . 3) ("filler" . nil) - ("filler" . nil) ("item @5" . 3)) - src) - (let ((old (set-marker (make-marker) 3 src))) - (cj/--agenda-frame-restore-point old 4)) - ;; lines 2 and 5 both point at src pos 3; nearest to old-line 4 is line 5. - (should (= (line-number-at-pos) 5))) - (kill-buffer src)))) - -(ert-deftest test-org-agenda-frame-restore-point-missing-clamps () - "Boundary: a gone marker clamps the old line into range and lands on an item." - (let ((src (generate-new-buffer " *rp-src*"))) - (unwind-protect - (with-temp-buffer - (with-current-buffer src (insert "aaaaaaaaaa\n")) - (test-org-agenda-frame--make-agenda-buffer - '(("header" . nil) ("item" . 3) ("item" . 5)) - src) - ;; old-line 99 is past the end; clamp to last line (an item). - (let ((gone (set-marker (make-marker) 99 src))) - (cj/--agenda-frame-restore-point gone 99)) - (should (get-text-property (line-beginning-position) 'org-marker))) - (kill-buffer src)))) - -(ert-deftest test-org-agenda-frame-restore-point-header-goes-to-first-item () - "Boundary: with no marker match, a header line moves to the first item." - (let ((src (generate-new-buffer " *rp-src*"))) - (unwind-protect - (with-temp-buffer - (with-current-buffer src (insert "aaaaaaaaaa\n")) - (test-org-agenda-frame--make-agenda-buffer - '(("header" . nil) ("item one" . 3) ("item two" . 5)) - src) - (cj/--agenda-frame-restore-point nil 1) ; line 1 is the header - (should (= (line-number-at-pos) 2)) - (should (get-text-property (line-beginning-position) 'org-marker))) - (kill-buffer src)))) - -(ert-deftest test-org-agenda-frame-restore-point-empty-buffer-start () - "Error: an empty (item-less) view leaves point at buffer start." - (with-temp-buffer - (test-org-agenda-frame--make-agenda-buffer - '(("only a header" . nil) ("no items here" . nil)) nil) - (cj/--agenda-frame-restore-point nil 2) - (should (= (point) (point-min))))) - -;;; Phase 2 — snapshot marker cloning - -(ert-deftest test-org-agenda-frame-clone-and-reinstall-markers () - "Normal: cloned markers survive nulling the originals and reinstall live." - (let ((src (generate-new-buffer " *clone-src*"))) - (unwind-protect - (let (clones) - (with-temp-buffer - (with-current-buffer src (insert "0123456789\n")) - (test-org-agenda-frame--make-agenda-buffer '(("item" . 4)) src) - (setq clones (cj/--agenda-frame-snapshot-markers (current-buffer))) - ;; Simulate org-agenda-reset-markers nulling the buffer's originals. - (let ((orig (get-text-property (point-min) 'org-marker))) - (set-marker orig nil))) - ;; Reinstall into a fresh buffer copy; the clone must still be live. - (with-temp-buffer - (test-org-agenda-frame--make-agenda-buffer '(("item" . nil)) nil) - (cj/--agenda-frame-reinstall-markers (current-buffer) clones) - (let ((m (get-text-property (point-min) 'org-marker))) - (should (markerp m)) - (should (eq (marker-buffer m) src)) - (should (= (marker-position m) 4))))) - (kill-buffer src)))) - -;;; Phase 2 — failure latch (report once per consecutive-failure run) - -(ert-deftest test-org-agenda-frame-failure-latch-reports-once () - "Normal: the first failure of a run reports; subsequent ones stay silent." - (let ((params '())) - (cl-letf (((symbol-function 'frame-parameter) - (lambda (_f p) (alist-get p params))) - ((symbol-function 'set-frame-parameter) - (lambda (_f p v) (setf (alist-get p params) v)))) - (should (cj/--agenda-frame-record-failure 'af)) ; 0 -> 1, report - (should-not (cj/--agenda-frame-record-failure 'af)) ; 1 -> 2, silent - (cj/--agenda-frame-clear-failure 'af) - (should (cj/--agenda-frame-record-failure 'af))))) ; reset -> report again - -;;; Phase 2 — timer start + duplicate prevention - -(ert-deftest test-org-agenda-frame-start-timer-sets-timer () - "Normal: start-timer schedules and stores a timer when none exists." - (let (stored) - (cl-letf (((symbol-function 'frame-parameter) (lambda (_f _p) nil)) - ((symbol-function 'run-at-time) (lambda (&rest _) 'the-timer)) - ((symbol-function 'set-frame-parameter) - (lambda (_f _p v) (setq stored v)))) - (should (eq (cj/--agenda-frame-start-timer 'af) 'the-timer)) - (should (eq stored 'the-timer))))) - -(ert-deftest test-org-agenda-frame-start-timer-no-duplicate () - "Boundary: a frame already carrying a live timer is not given a second one." - (let (called) - (cl-letf (((symbol-function 'frame-parameter) (lambda (_f _p) 'existing)) - ((symbol-function 'timerp) (lambda (x) (eq x 'existing))) - ((symbol-function 'run-at-time) (lambda (&rest _) (setq called t) 'new))) - (cj/--agenda-frame-start-timer 'af) - (should-not called)))) - -;;; Phase 2 — do-redo orchestration (success and failure branches) - -(ert-deftest test-org-agenda-frame-do-redo-success-clears-and-releases () - "Normal: a successful redo clears the failure latch and releases the snapshot." - (let ((params (list (cons 'cj/agenda-frame-fail-count 3))) - released) - (with-temp-buffer - (insert "agenda line\n") - (cl-letf (((symbol-function 'org-agenda-redo) (lambda (&rest _) nil)) - ((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) - ((symbol-function 'set-frame-parameter) - (lambda (_f p v) (setf (alist-get p params) v))) - ((symbol-function 'cj/--agenda-frame-release-snapshot) - (lambda (_s) (setq released t)))) - (cj/--agenda-frame-do-redo 'af (current-buffer) nil) - (should (equal (alist-get 'cj/agenda-frame-fail-count params) 0)) - (should released))))) - -(ert-deftest test-org-agenda-frame-do-redo-error-restores-reenables-reports () - "Error: a redo that fails mid-rebuild restores the last-good buffer verbatim, -re-enables the policy, shows one overlay, and reports once." - (let ((params '()) msgs) - (with-temp-buffer - (insert "good agenda content\n") - (unwind-protect - (cl-letf (((symbol-function 'org-agenda-redo) - (lambda (&rest _) (erase-buffer) (insert "PARTIAL") (error "boom"))) - ((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) - ((symbol-function 'set-frame-parameter) - (lambda (_f p v) (setf (alist-get p params) v))) - ((symbol-function 'message) - (lambda (fmt &rest a) (push (apply #'format fmt a) msgs)))) - (cj/--agenda-frame-do-redo 'af (current-buffer) nil) - (should cj/agenda-frame-mode) ; policy re-enabled - (should (= 1 (length (cj/--agenda-frame-failure-overlays - (current-buffer))))) ; overlay shown - (should (string-match-p "good agenda content" (buffer-string))) ; restored - (should-not (string-match-p "PARTIAL" (buffer-string))) - (should (= 1 (seq-count (lambda (m) (string-match-p "refresh failed" m)) - msgs)))) - (cj/agenda-frame-mode -1) - (cj/--agenda-frame-remove-overlay (current-buffer)))))) - -(ert-deftest test-org-agenda-frame-do-redo-follows-item-across-shift () - "Normal: on a successful redo, point follows the same source item even when -lines shift and the buffer's own markers are nulled (the reset-markers case). -Guards against restoring by raw line number after the item moved." - (let ((src (generate-new-buffer " *shift-src*")) - (params '())) - (unwind-protect - (with-temp-buffer - (with-current-buffer src (insert "0123456789\n")) - ;; Before: item B (src pos 5) sits on line 3, and point is on it. - (test-org-agenda-frame--make-agenda-buffer - '(("header" . nil) ("item A" . 3) ("item B" . 5)) src) - (goto-char (point-min)) (forward-line 2) ; line 3, item B - (cl-letf (((symbol-function 'frame-parameter) (lambda (_f p) (alist-get p params))) - ((symbol-function 'set-frame-parameter) - (lambda (_f p v) (setf (alist-get p params) v))) - ((symbol-function 'org-agenda-redo) - (lambda (&rest _) - ;; Null the buffer's originals (as org-agenda-reset-markers - ;; does), then rebuild with item B shifted to line 4. - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (let ((m (get-text-property (line-beginning-position) 'org-marker))) - (when (markerp m) (set-marker m nil))) - (forward-line 1))) - (erase-buffer) - (test-org-agenda-frame--make-agenda-buffer - '(("header" . nil) ("new item" . 1) ("item A" . 3) ("item B" . 5)) - src)))) - (cj/--agenda-frame-do-redo 'af (current-buffer) nil)) - ;; Point should be on the rebuilt item B (src pos 5), now line 4 -- - ;; not clamped to old line 3 (which is now item A, src pos 3). - (let ((m (get-text-property (line-beginning-position) 'org-marker))) - (should (markerp m)) - (should (= (marker-position m) 5)))) - (kill-buffer src)))) - -;;; Phase 2 — snapshot round-trip, release, safe-redo window contract, overlay - -(ert-deftest test-org-agenda-frame-restore-snapshot-round-trip () - "Normal: snapshot then restore reinstates text and a live cloned marker." - (let ((src (generate-new-buffer " *ss-src*"))) - (unwind-protect - (with-temp-buffer - (with-current-buffer src (insert "0123456789\n")) - (test-org-agenda-frame--make-agenda-buffer '(("item alpha" . 4)) src) - (let ((snap (cj/--agenda-frame-snapshot (current-buffer) nil))) - (erase-buffer) - (insert "CORRUPT") - (cj/--agenda-frame-restore-snapshot (current-buffer) snap nil) - (should (string-match-p "item alpha" (buffer-string))) - (let ((m (get-text-property (point-min) 'org-marker))) - (should (markerp m)) - (should (eq (marker-buffer m) src)) - (should (= (marker-position m) 4))) - (cj/--agenda-frame-release-snapshot snap) - (should-not (marker-buffer (cdr (car (plist-get snap :markers))))))) - (kill-buffer src)))) - -(ert-deftest test-org-agenda-frame-safe-redo-selects-and-restores-window () - "Normal: the active tick runs the redo and restores the prior window (no focus theft)." - (let (redone (prev (selected-window))) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) - (lambda () (current-buffer))) - ((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'get-buffer-window) (lambda (&rest _) prev)) - ((symbol-function 'cj/--agenda-frame-do-redo) - (lambda (&rest _) (setq redone t)))) - (cj/--agenda-frame-safe-redo) - (should redone) - (should (eq (selected-window) prev))))) - -(ert-deftest test-org-agenda-frame-overlay-idempotent () - "Boundary: showing the failure overlay twice keeps a single overlay." - (with-temp-buffer - (insert "x\n") - (unwind-protect - (progn - (cj/--agenda-frame-show-failure-overlay (current-buffer)) - (let ((first (car (cj/--agenda-frame-failure-overlays (current-buffer))))) - (cj/--agenda-frame-show-failure-overlay (current-buffer)) - (should (equal (cj/--agenda-frame-failure-overlays (current-buffer)) - (list first))) - (should (= 1 (seq-count (lambda (o) (overlay-get o 'before-string)) - (overlays-in (point-min) (point-max))))))) - (cj/--agenda-frame-remove-overlay (current-buffer))))) - -;;; Phase 2 — public command + F8-family rebind - -(ert-deftest test-org-agenda-frame-public-toggle-wraps-private () - "Normal: the interactive command delegates to the private toggle." - (let (called) - (cl-letf (((symbol-function 'cj/--agenda-frame-toggle) - (lambda () (setq called t)))) - (call-interactively 'cj/agenda-frame-toggle) - (should called)))) - -(ert-deftest test-org-agenda-frame-parameters-normal-tiled-frame () - "Boundary: the agenda frame is a normal frame (the tiling WM places it -side by side with the working frame), carrying the marker and a distinct name." - (let ((params (cj/--agenda-frame-make-parameters))) - (should (assq cj/--agenda-frame-parameter params)) - (should (equal (cdr (assq 'name params)) "Full Agenda")) - ;; No fullscreen request -- a fullboth frame would cover the whole output - ;; instead of tiling beside the working frame. - (should-not (assq 'fullscreen params)))) - -(ert-deftest test-org-agenda-frame-spawn-binds-sticky-and-current-window () - "Normal: spawn dynamically binds sticky + current-window around the render. -The custom command's own settings apply too late to name the buffer, so -without these bindings the buffer is plain *Org Agenda* -- which matches -the 0.75 below-selected display rule and splits the new frame with the -working buffer left on top." - (let (seen-sticky seen-setup) - (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) - ((symbol-function 'make-frame) (lambda (&rest _) 'af)) - ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) - ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) - ((symbol-function 'org-agenda) - (lambda (&rest _) - (setq seen-sticky org-agenda-sticky - seen-setup org-agenda-window-setup))) - ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) - ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) - (cj/--agenda-frame-spawn) - (should (eq seen-sticky t)) - (should (eq seen-setup 'current-window))))) - -(ert-deftest test-org-agenda-frame-spawn-forces-single-window () - "Boundary: spawn collapses the frame to one window after rendering. -A display rule that still splits the frame must not leave a second window -showing the launch buffer." - (let (collapsed) - (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) - ((symbol-function 'make-frame) (lambda (&rest _) 'af)) - ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) - ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) - ((symbol-function 'org-agenda) (lambda (&rest _) nil)) - ((symbol-function 'delete-other-windows) - (lambda (&rest _) (setq collapsed t))) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) - ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) - (cj/--agenda-frame-spawn) - (should collapsed)))) - -(ert-deftest test-org-agenda-frame-spawn-resets-span-to-7 () - "Normal: a fresh spawn opens at the documented seven-day default, even when a -prior frame's session left `cj/--agenda-frame-span' at the day view." - (let ((cj/--agenda-frame-span 1)) - (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) - ((symbol-function 'make-frame) (lambda (&rest _) 'af)) - ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) - ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) - ((symbol-function 'org-agenda) (lambda (&rest _) nil)) - ((symbol-function 'delete-other-windows) (lambda (&rest _) nil)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) - ((symbol-function 'cj/--agenda-frame-start-timer) (lambda (_f) nil))) - (cj/--agenda-frame-spawn) - (should (equal cj/--agenda-frame-span 7))))) - -(ert-deftest test-org-agenda-frame-spawn-starts-timer () - "Normal: a successful spawn starts the refresh timer for the new frame." - (let (timed) - (cl-letf (((symbol-function 'selected-frame) (lambda () 'launch)) - ((symbol-function 'make-frame) (lambda (&rest _) 'af)) - ((symbol-function 'select-frame-set-input-focus) (lambda (_f &rest _) nil)) - ((symbol-function 'cj/build-org-agenda-list) (lambda (&rest _) nil)) - ((symbol-function 'org-agenda) (lambda (&rest _) nil)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) - ((symbol-function 'cj/--agenda-frame-start-timer) - (lambda (f) (setq timed f)))) - (should (eq (cj/--agenda-frame-spawn) 'af)) - (should (eq timed 'af))))) - -(ert-deftest test-org-agenda-frame-safe-redo-inhibits-redisplay () - "Normal: the tick runs with redisplay inhibited. -The rebuild takes visible time; without this, the agenda window is the -selected window for the whole rebuild and the user watches their cursor -go hollow every five minutes -- indistinguishable from focus theft." - (let (seen (prev (selected-window))) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) - (lambda () (current-buffer))) - ((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'get-buffer-window) (lambda (&rest _) prev)) - ((symbol-function 'cj/--agenda-frame-do-redo) - (lambda (&rest _) (setq seen inhibit-redisplay)))) - (cj/--agenda-frame-safe-redo) - (should (eq seen t))))) - -(ert-deftest test-org-agenda-frame-safe-redo-skips-during-minibuffer () - "Boundary: a tick while a minibuffer is active is skipped entirely. -Reselecting windows under an active minibuffer session can break it; the -next tick catches up." - (let (redone (prev (selected-window))) - (cl-letf (((symbol-function 'active-minibuffer-window) (lambda () 'mini)) - ((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) - (lambda () (current-buffer))) - ((symbol-function 'frame-live-p) (lambda (_f) t)) - ((symbol-function 'get-buffer-window) (lambda (&rest _) prev)) - ((symbol-function 'cj/--agenda-frame-do-redo) - (lambda (&rest _) (setq redone t)))) - (cj/--agenda-frame-safe-redo) - (should-not redone)))) - -(ert-deftest test-org-agenda-frame-safe-redo-noop-when-not-shown () - "Boundary: a tick with the buffer not shown in the frame does not redo or error." - (let (redone) - (cl-letf (((symbol-function 'cj/--agenda-frame) (lambda () 'af)) - ((symbol-function 'cj/--agenda-frame-sticky-buffer) (lambda () nil)) - ((symbol-function 'get-buffer-window) (lambda (&rest _) nil)) - ((symbol-function 'cj/--agenda-frame-do-redo) - (lambda (&rest _) (setq redone t)))) - (cj/--agenda-frame-safe-redo) - (should-not redone)))) - -(ert-deftest test-org-agenda-frame-install-keys-rebinds-f8-family () - "Normal: S-<f8> toggles the frame; the force-rescan moves to C-M-<f8>." - (let ((map (make-sparse-keymap))) - (cj/--agenda-frame-install-keys map) - (should (eq (lookup-key map (kbd "S-<f8>")) 'cj/agenda-frame-toggle)) - (should (eq (lookup-key map (kbd "C-M-<f8>")) 'cj/org-agenda-refresh-files)))) - -(provide 'test-org-agenda-frame) -;;; test-org-agenda-frame.el ends here diff --git a/tests/test-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--pin-go-treesit-revision.el b/tests/test-prog-general--pin-go-treesit-revision.el new file mode 100644 index 00000000..42845b4f --- /dev/null +++ b/tests/test-prog-general--pin-go-treesit-revision.el @@ -0,0 +1,51 @@ +;;; test-prog-general--pin-go-treesit-revision.el --- Go grammar pinning -*- lexical-binding: t; -*- + +;;; Commentary: +;; The treesit-auto Go recipe is pinned for compatibility with Emacs 30.2. +;; Keep the mutation independent of cl-defstruct's compile-time setter +;; expansion: prog-general is loaded before treesit-auto defines that setter +;; during a normal startup. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +;; Deliberately put `revision' at a different offset from treesit-auto's real +;; struct. The production helper must discover the slot rather than hard-code +;; the package's current vector layout. +(cl-defstruct treesit-auto-recipe lang revision url) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'prog-general) + +(ert-deftest test-prog-general-pin-go-treesit-revision-updates-go () + "Normal: the Go recipe receives the supported grammar revision." + (let* ((go (make-treesit-auto-recipe + :lang 'go :revision "main" :url "https://example.test/go")) + (python (make-treesit-auto-recipe + :lang 'python :revision "main" + :url "https://example.test/python"))) + (cj/treesit-auto-pin-go-revision (list python go)) + (should (equal (treesit-auto-recipe-revision go) "v0.19.1")) + (should (equal (treesit-auto-recipe-revision python) "main")))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-no-go-is-no-op () + "Boundary: a recipe list without Go remains unchanged." + (let ((python (make-treesit-auto-recipe + :lang 'python :revision "main" + :url "https://example.test/python"))) + (should-not (cj/treesit-auto-pin-go-revision (list python))) + (should (equal (treesit-auto-recipe-revision python) "main")))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-empty-is-no-op () + "Boundary: an empty recipe list does not signal an error." + (should-not (cj/treesit-auto-pin-go-revision nil))) + +(ert-deftest test-prog-general-pin-go-treesit-revision-malformed-recipe-errors () + "Error: a malformed recipe signals instead of silently skipping the pin." + (should-error (cj/treesit-auto-pin-go-revision '(not-a-recipe)) + :type 'wrong-type-argument)) + +(provide 'test-prog-general--pin-go-treesit-revision) +;;; test-prog-general--pin-go-treesit-revision.el ends here diff --git a/tests/test-prog-general-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 new file mode 100644 index 00000000..8f5b62bd --- /dev/null +++ b/tests/test-telega-config--docker-pin.el @@ -0,0 +1,212 @@ +;;; test-telega-config--docker-pin.el --- Tests for the telega docker image pin -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for pinning the telega-server container image. +;; +;; telega infers its image from `telega-tdlib-min-version' and only pins to a +;; version tag when min and max versions are equal and the version ends in +;; ".0". This config has min "1.8.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: + +(require 'ert) +(require 'cl-lib) + +(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 () + "Normal: a configured pin is returned verbatim." + (let ((cj/telega-docker-image "zevlg/telega-server@sha256:abc123")) + (should (equal (cj/--telega-docker-pinned-image) + "zevlg/telega-server@sha256:abc123")))) + +(ert-deftest test-telega-config-pin-nil-when-unset () + "Boundary: no pin returns nil so telega's own inference stays in charge." + (let ((cj/telega-docker-image nil)) + (should-not (cj/--telega-docker-pinned-image)))) + +(ert-deftest test-telega-config-pin-nil-for-empty-string () + "Boundary: an empty or whitespace pin is not a reference. +An empty string would otherwise reach the docker command line as a blank +image argument, which fails in a way that looks unrelated to this setting." + (let ((cj/telega-docker-image "")) + (should-not (cj/--telega-docker-pinned-image))) + (let ((cj/telega-docker-image " ")) + (should-not (cj/--telega-docker-pinned-image)))) + +(ert-deftest test-telega-config-pin-nil-for-non-string () + "Error: a non-string pin is ignored rather than passed to the shell." + (let ((cj/telega-docker-image 'latest)) + (should-not (cj/--telega-docker-pinned-image))) + (let ((cj/telega-docker-image 42)) + (should-not (cj/--telega-docker-pinned-image)))) + +(ert-deftest test-telega-config-pin-trims-surrounding-whitespace () + "Boundary: a pin with stray whitespace is trimmed, not rejected. +A trailing newline is easy to introduce when pasting a digest from docker." + (let ((cj/telega-docker-image " zevlg/telega-server@sha256:abc123\n")) + (should (equal (cj/--telega-docker-pinned-image) + "zevlg/telega-server@sha256:abc123")))) + +;; -- cj/--telega-docker-image-name (the advice) ------------------------------ + +(ert-deftest test-telega-config-image-advice-prefers-the-pin () + "Normal: with a pin set, the advice returns it instead of calling telega." + (let ((cj/telega-docker-image "zevlg/telega-server@sha256:abc123") + (called nil)) + (should (equal (cj/--telega-docker-image-name + (lambda () (setq called t) "zevlg/telega-server:latest")) + "zevlg/telega-server@sha256:abc123")) + (should-not called))) + +(ert-deftest test-telega-config-image-advice-delegates-without-a-pin () + "Boundary: with no pin, telega's own inference is used unchanged. +Removing the pin must restore stock behavior rather than break the image +name, so this stays a reversible setting." + (let ((cj/telega-docker-image nil)) + (should (equal (cj/--telega-docker-image-name + (lambda () "zevlg/telega-server:latest")) + "zevlg/telega-server:latest")))) + +(ert-deftest test-telega-config-image-advice-is-named-and-removable () + "Normal: the advice is a named function so it can be removed by reference." + (should (fboundp 'cj/--telega-docker-image-name))) + +;; -- 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 "\\`[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--server-death.el b/tests/test-telega-config--server-death.el new file mode 100644 index 00000000..1151fa7e --- /dev/null +++ b/tests/test-telega-config--server-death.el @@ -0,0 +1,131 @@ +;;; test-telega-config--server-death.el --- Tests for the telega-server death alert -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for the telega-server death sentinel. telega's own sentinel only +;; calls `message' on an abnormal exit, which scrolls away unseen -- so a +;; dead server reads as a quiet Telegram. These pin the alert that replaces +;; that silence. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'telega-config) + +;; -- cj/--telega-server-death-p ---------------------------------------------- + +(ert-deftest test-telega-config-death-p-nonzero-status-is-death () + "Normal: a non-zero exit status is an abnormal death." + (should (cj/--telega-server-death-p 1)) + (should (cj/--telega-server-death-p 139))) + +(ert-deftest test-telega-config-death-p-segv-signal-is-death () + "Normal: a signal number (SIGSEGV is 11) counts as death. +This is the observed failure -- the server segfaults rather than exiting." + (should (cj/--telega-server-death-p 11))) + +(ert-deftest test-telega-config-death-p-zero-is-clean-exit () + "Boundary: exit status 0 is a clean shutdown and must not alert. +Quitting telega deliberately would otherwise page on every exit." + (should-not (cj/--telega-server-death-p 0))) + +(ert-deftest test-telega-config-death-p-nil-is-not-death () + "Boundary: nil status (no status available) is not a death." + (should-not (cj/--telega-server-death-p nil))) + +(ert-deftest test-telega-config-death-p-non-integer-is-not-death () + "Error: a non-integer status returns nil rather than signalling. +`process-exit-status' is documented to return an integer, but this runs +inside telega's sentinel where an error would disrupt telega's own cleanup." + (should-not (cj/--telega-server-death-p "segfault")) + (should-not (cj/--telega-server-death-p 'exited))) + +;; -- cj/--telega-server-exit-status ------------------------------------------ + +(ert-deftest test-telega-config-exit-status-nil-for-non-process () + "Error: a nil or non-process argument yields nil, not a signal. +The sentinel hands us whatever it has; a bad object must not break telega." + (should-not (cj/--telega-server-exit-status nil)) + (should-not (cj/--telega-server-exit-status "not-a-process"))) + +;; -- cj/--telega-server-death-body ------------------------------------------- + +(ert-deftest test-telega-config-death-body-names-status-and-effect () + "Normal: the body carries the status and says coverage is affected. +The status distinguishes a segfault from a clean kill; the effect is why +the reader should care." + (let ((body (cj/--telega-server-death-body 11 "segmentation fault\n"))) + (should (string-match-p "11" body)) + (should (string-match-p "Telegram" body)))) + +(ert-deftest test-telega-config-death-body-strips-trailing-newline () + "Boundary: a sentinel event string ends in a newline; it must not survive. +A trailing newline in a desktop notification body renders as dead space." + (let ((body (cj/--telega-server-death-body 11 "segmentation fault\n"))) + (should-not (string-suffix-p "\n" body)))) + +(ert-deftest test-telega-config-death-body-handles-empty-event () + "Boundary: an empty or nil event still produces a usable body." + (should (stringp (cj/--telega-server-death-body 11 nil))) + (should (stringp (cj/--telega-server-death-body 11 ""))) + (should (string-match-p "11" (cj/--telega-server-death-body 11 nil)))) + +(ert-deftest test-telega-config-death-body-handles-unicode-event () + "Boundary: a non-ASCII event string passes through intact." + (let ((body (cj/--telega-server-death-body 1 "ошибка сервера\n"))) + (should (string-match-p "ошибка" body)))) + +;; -- cj/--telega-server-notify-death (the advice) ---------------------------- + +(defmacro test-telega-config--with-status (status captured &rest body) + "Run BODY with the exit status forced to STATUS. +Notification calls are captured into CAPTURED as (TITLE . BODY) pairs." + (declare (indent 2)) + `(let ((,captured nil)) + (cl-letf (((symbol-function 'cj/--telega-server-exit-status) + (lambda (&rest _) ,status)) + ((symbol-function 'cj/--telega-server-send-notification) + (lambda (title body) (push (cons title body) ,captured)))) + ,@body))) + +(ert-deftest test-telega-config-notify-fires-on-abnormal-exit () + "Normal: an abnormal exit sends exactly one notification." + (test-telega-config--with-status 11 sent + (cj/--telega-server-notify-death nil "segmentation fault\n") + (should (= 1 (length sent))) + (should (string-match-p "telega" (downcase (car (car sent))))))) + +(ert-deftest test-telega-config-notify-silent-on-clean-exit () + "Boundary: a clean exit sends nothing. +Deliberately quitting telega must not page." + (test-telega-config--with-status 0 sent + (cj/--telega-server-notify-death nil "finished\n") + (should-not sent))) + +(ert-deftest test-telega-config-notify-silent-without-status () + "Boundary: no recoverable status sends nothing rather than a bare alert." + (test-telega-config--with-status nil sent + (cj/--telega-server-notify-death nil "gone\n") + (should-not sent))) + +(ert-deftest test-telega-config-notify-contains-notifier-errors () + "Error: a failing notifier must not escape into telega's sentinel. +This runs as :after advice on `telega-server--sentinel'; an error here +would abort telega's own status handling and its relogin path." + (cl-letf (((symbol-function 'cj/--telega-server-exit-status) + (lambda (&rest _) 11)) + ((symbol-function 'cj/--telega-server-send-notification) + (lambda (&rest _) (error "notifier unavailable")))) + (should (progn (cj/--telega-server-notify-death nil "segfault\n") t)))) + +(ert-deftest test-telega-config-notify-advice-is-named-and-removable () + "Normal: the sentinel advice is installed by name, so it can be removed. +An anonymous lambda can't be `advice-remove'd by reference, which strands +the old advice in a live daemon after the source stops installing it." + (should (fboundp 'cj/--telega-server-notify-death)) + (should (symbolp 'cj/--telega-server-notify-death))) + +(provide 'test-telega-config--server-death) +;;; test-telega-config--server-death.el ends here diff --git a/tests/test-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 diff --git a/tests/testutil-calendar-sync.el b/tests/testutil-calendar-sync.el index 2187c56c..60f878d0 100644 --- a/tests/testutil-calendar-sync.el +++ b/tests/testutil-calendar-sync.el @@ -172,6 +172,22 @@ Returns float number of days (positive if date2 > date1)." (t2 (calendar-sync--date-to-time (list (nth 0 date2) (nth 1 date2) (nth 2 date2))))) (/ (float-time (time-subtract t2 t1)) 86400.0))) +(defun test-calendar-sync-time-monthly-anchor (hour minute) + "Return a soon-future date on a day-of-month that every month has. +Walks forward from tomorrow to the first date whose day is 28 or less, then +returns it at HOUR:MINUTE. + +Use this instead of `test-calendar-sync-time-days-from-now' for any test that +asserts a monthly cadence. A relative offset is not a date-independent anchor: +its day-of-month varies with the run date, and a monthly series anchored on the +29th, 30th, or 31st correctly appears only in the months that have that day. A +test asserting roughly one occurrence per month then fails for several days each +month, which is what happened on 2026-07-30." + (let ((days 1)) + (while (> (nth 2 (test-calendar-sync-time-days-from-now days hour minute)) 28) + (setq days (1+ days))) + (test-calendar-sync-time-days-from-now days hour minute))) + (defun test-calendar-sync-wide-range () "Generate wide date range: 90 days past to 365 days future. Returns (start-time end-time) suitable for expansion functions." diff --git a/working/org-element-cache-persist-bug/README.org b/working/org-element-cache-persist-bug/README.org new file mode 100644 index 00000000..2ad8b1bf --- /dev/null +++ b/working/org-element-cache-persist-bug/README.org @@ -0,0 +1,94 @@ +#+TITLE: org-element persistent-cache corruption — reproduction evidence +#+AUTHOR: Craig Jennings +#+DATE: 2026-07-28 + +* What this is + +Evidence for the org-element cache corruption I chased on 2026-07-28, kept +because the diagnosis outlived the fix. I shipped a fix as =d2103877=, put it +through four hostile reviews, and reverted it on their findings. These scripts +are what the reviews were arguing about. + +Run any of them with: + +: emacs --batch -q -l <script> + +Several of the failing ones never terminate once corruption sets in, because +=org-element--cache-self-verify= floods warnings (one run reached 26 million +lines). Use =timeout=. + +* The actual bug + +=org-element--cache-persist-before-write= (org-element.el:7694) resolves +=(get-file-buffer ...)= and destructively nils =:buffer= on the *live* cache. +The next edit to that buffer then signals =wrong-type-argument stringp nil= +from =org-element--cache-after-change=. + +It needs no second buffer and no dirvish. That is the finding that killed the +fix: I had diagnosed a *trigger* and written the fix against it. + +Which buffer gets corrupted is decided by =buffer-list= order, since +=get-file-buffer= returns the first buffer visiting the file. That is why the +symptom is intermittent, and why any future fix needs a test that controls the +order rather than accepting whatever the harness happens to produce. + +* The scripts + +| File | What it shows | +|----------------------------+-----------------------------------------------------------| +| =hostile-d-nopreview.el= | The root cause. One org buffer, no preview, no dirvish. | +| | =org-persist-write-all-buffer= alone strips =:buffer= | +| | from 6134 elements and the next insert signals. | +|----------------------------+-----------------------------------------------------------| +| =hostile-d-order.el= | Corruption depends on =buffer-list= order. Bury the real | +| | buffer and =get-file-buffer= returns the other one, and | +| | the run comes back clean. | +|----------------------------+-----------------------------------------------------------| +| =hostile-d-faithful.el= | A faithful replay of dirvish's preview, with the real | +| | =dirvish-preview-environment= bindings and buffer naming. | +| | Reproduces. My own replay below was looser. | +|----------------------------+-----------------------------------------------------------| +| =hostile-c-repro.el= | The regression the reverted fix introduced: with | +| | =org-element-cache-persistent= nil in a preview buffer, | +| | =org-element-cache-reset= unregisters the *real* file's | +| | persisted cache and removes it from disk. | +|----------------------------+-----------------------------------------------------------| +| =hostile-a-errorbranch.el= | dirvish.el:671-680 kills the preview buffer on a signal | +| | without ever running =dirvish-preview-setup-hook=, so a | +| | hook-based fix is skipped there. Needs =so-long= enabled | +| | to reach, which it is not here today. | +|----------------------------+-----------------------------------------------------------| +| =hostile-e-ffnoselect.el= | =dirvish--find-file-temporarily= returns the user's | +| | existing buffer, which dirvish later kills. Separate | +| | pre-existing bug, tracked as its own task. | +|----------------------------+-----------------------------------------------------------| +| =repro-preview-cache.el= | My original replay. Kept as the record of what I ran, | +| | not as good evidence: its control differs from it by | +| | three variables, so on its own it cannot attribute cause. | +|----------------------------+-----------------------------------------------------------| +| =control-no-preview.el= | That flawed control. | +|----------------------------+-----------------------------------------------------------| +| =variant-no-kill.el= | Preview created but not killed: clean. Supported the | +| | "the kill is required" framing, which turned out to be | +| | backwards. The persist *write* is causal; the kill only | +| | triggers it. | +|----------------------------+-----------------------------------------------------------| +| =variant-no-persist.el= | Same sequence with persistence off: clean. | +|----------------------------+-----------------------------------------------------------| +| =verify-shipped-fix.el= | The reverted fix suppressing the corruption on the | +| | dirvish path. It did work there. It was aimed one layer | +| | too low and carried a regression. | +|----------------------------+-----------------------------------------------------------| +| =d2103877-reverted.patch= | The reverted commit, kept so the approach is recoverable. | +|----------------------------+-----------------------------------------------------------| + +* What does not reproduce it + +Turning =org-element--cache-self-verify= on does *not* manufacture the error. +It reproduces at org's defaults; self-verify only makes it loud. I had worried +the instrumentation was creating the signal, and it is not. + +* Filed as + +See =todo.org=: the org-element persist task, and the separate dirvish +=find-file-noselect= buffer-kill task. diff --git a/working/org-element-cache-persist-bug/attempt2-tests-blind.el b/working/org-element-cache-persist-bug/attempt2-tests-blind.el new file mode 100644 index 00000000..4e9c4f37 --- /dev/null +++ b/working/org-element-cache-persist-bug/attempt2-tests-blind.el @@ -0,0 +1,190 @@ +;;; test-dirvish-config--preview-org-cache-env.el --- preview org-cache opt-out -*- lexical-binding: t; -*- + +;;; Commentary: +;; Dirvish's fallback preview builds a throwaway buffer, points `buffer-file-name' +;; at the real file (dirvish.el:667) and runs `set-auto-mode' (dirvish.el:671). +;; Previewing an .org file therefore makes a real org-mode buffer that registers +;; with org-persist and picks up a buffer-local `org-persist-write-all-buffer' on +;; `kill-buffer-hook'. When dirvish kills that buffer, the write fires, +;; `org-element--cache-persist-before-write' resolves `get-file-buffer' to the +;; user's REAL buffer, and nils `:buffer' across its live element cache. The next +;; access to a cached headline then runs +;; `org-element--headline-parse-title', whose first form is +;; `(with-current-buffer (org-element-property :buffer headline))' -- and +;; `set-buffer' on nil signals `wrong-type-argument stringp nil'. +;; +;; Dirvish let-binds `dirvish-preview-environment' around `set-auto-mode', so +;; adding `(org-element-use-cache . nil)' there stops the preview buffer ever +;; registering. Nothing is written mid-session and the real buffer is untouched. +;; +;; Coverage note, stated plainly: the wiring tests below assert the alist entry, +;; and the behavioral test drives the corruption sequence directly rather than +;; through dirvish. Neither runs dirvish's own preview machinery, so a change in +;; how dirvish applies the environment would not be caught here. That gap is +;; covered by a live check in the running daemon. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'package) +(require 'org) +(require 'org-element) +(require 'org-persist) + +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "elpa/dirvish-2.3.0/extensions" + user-emacs-directory)) +(require 'user-constants) +(require 'keybindings) +(require 'dirvish-config) + +;;; ----------------------------- the wiring ----------------------------------- + +(ert-deftest test-dirvish-preview-env-disables-org-cache () + "Normal: `dirvish-preview-environment' turns the element cache off. +This is the entry dirvish let-binds around `set-auto-mode', so it is what keeps +an org preview buffer from registering with org-persist." + (should (member '(org-element-use-cache . nil) dirvish-preview-environment))) + +(ert-deftest test-dirvish-preview-env-keeps-upstream-entries () + "Boundary: the upstream entries survive alongside ours. +Replacing the alist rather than extending it would silently drop dirvish's own +bindings, and preview would start honouring dir-locals and printing messages." + (dolist (pair '((inhibit-message . t) + (non-essential . t) + (enable-dir-local-variables . nil) + (enable-local-variables . :safe))) + (should (member pair dirvish-preview-environment)))) + +(ert-deftest test-dirvish-preview-env-entry-is-not-duplicated () + "Boundary: the entry appears exactly once. +The module can be re-loaded into a running daemon, so the wiring has to be +idempotent rather than appending on every load." + (should (= 1 (cl-count 'org-element-use-cache dirvish-preview-environment + :key #'car)))) + +;;; --------------------------- the behavior ----------------------------------- + +(defun cj--test-preview-buffer (file env) + "Build a dirvish-style preview buffer for FILE with ENV bound, and return it. +Mirrors `dirvish--preview-file-maybe-truncate': real `buffer-file-name', then +`set-auto-mode' under the preview environment." + (with-current-buffer (get-buffer-create "*cj-test-preview*") + (with-silent-modifications + (insert-file-contents file nil 0 1048576) + (setq buffer-file-name file) + (goto-char (point-min)) + (rename-buffer (format "PREVIEW :: 1 :: %s" (file-name-nondirectory file)))) + ;; Dynamic `eval', matching dirvish.el:672 -- NOT lexical. Under lexical + ;; binding a non-special symbol would bind lexically and never reach + ;; `set-auto-mode', so the replay would silently no-op and the test would + ;; pass for the wrong reason. Same trap as the json-object-type gotcha. + (eval `(let ,(mapcar (lambda (e) `(,(car e) ',(cdr e))) env) + (setq-local delay-mode-hooks t) + (set-auto-mode) + (font-lock-mode 1))) + (current-buffer))) + +(defun cj--test-persisted-p (file) + "Return non-nil when FILE still has a registered org-element cache collection." + (and (org-persist--find-index + (org-persist--normalize-associated (list :file file))) + t)) + +(defun cj--test-cached-buffers (buf) + "Return the distinct `:buffer' values cached in BUF's element cache." + (with-current-buffer buf + (let (seen) + (avl-tree-mapc (lambda (el) (push (org-element-property :buffer el) seen)) + org-element--cache) + (delete-dups seen)))) + +(defmacro cj--with-org-fixture (var &rest body) + "Bind VAR to a live buffer visiting a populated org fixture, then run BODY." + (declare (indent 1)) + `(let* ((dir (make-temp-file "cj-preview-" t)) + (org-persist-directory (expand-file-name "persist" dir)) + (file (expand-file-name "notes.org" dir)) + (org-element-use-cache t) + (org-element-cache-persistent t) + (org-log-done nil)) + (with-temp-file file + (dotimes (i 30) (insert (format "* TODO task %d :t%d:\nbody %d\n" i i i)))) + (let ((,var (find-file-noselect file))) + (unwind-protect + (progn + (with-current-buffer ,var + (org-element-cache-reset) + (org-element-cache-map #'ignore :granularity 'headline) + ;; Closing a task is what actually lands parsed headline elements + ;; in the cache carrying a `:buffer'. Without it the cache stays + ;; empty and every assertion below passes vacuously against nil. + (goto-char (point-min)) + (re-search-forward "^\\* TODO task 0 ") + (beginning-of-line) + (org-todo "DONE")) + (should (cj--test-cached-buffers ,var)) + ,@body) + (when (buffer-live-p ,var) + (with-current-buffer ,var (set-buffer-modified-p nil)) + (kill-buffer ,var)) + (delete-directory dir t))))) + +(ert-deftest test-dirvish-preview-env-protects-the-real-buffer () + "Normal: previewing an already-open org file leaves its cache intact. +The whole point of the entry -- with it, killing the preview must not strip +`:buffer' from the real buffer's cached elements." + (cj--with-org-fixture real + (should (member real (cj--test-cached-buffers real))) + (let ((preview (cj--test-preview-buffer (buffer-file-name real) + dirvish-preview-environment))) + (let (kill-buffer-query-functions) (kill-buffer preview))) + (should (member real (cj--test-cached-buffers real))) + (should-not (member nil (cj--test-cached-buffers real))))) + +(ert-deftest test-dirvish-preview-env-real-buffer-still-parses () + "Normal: the real buffer still parses after the preview is killed. +Asserting on `:buffer' alone would pass against a cache that is broken in some +other way, so this drives the access path that actually signalled." + (cj--with-org-fixture real + (let ((preview (cj--test-preview-buffer (buffer-file-name real) + dirvish-preview-environment))) + (let (kill-buffer-query-functions) (kill-buffer preview))) + (with-current-buffer real + (should (equal "OK" + (condition-case err + (progn (org-element-cache-map + (lambda (el) (org-element-property :raw-value el)) + :granularity 'headline) + "OK") + (error (format "%S" err)))))))) + +(ert-deftest test-dirvish-preview-env-without-the-entry-corrupts () + "Error: the same sequence WITHOUT the entry does corrupt the real buffer. +This is the control. Without it the two tests above could pass because the +corruption never happens in this harness at all, rather than because the entry +prevents it." + (cj--with-org-fixture real + (let* ((bare (assq-delete-all 'org-element-use-cache + (copy-alist dirvish-preview-environment))) + (preview (cj--test-preview-buffer (buffer-file-name real) bare))) + (let (kill-buffer-query-functions) (kill-buffer preview))) + (should (member nil (cj--test-cached-buffers real))))) + +(ert-deftest test-dirvish-preview-env-spares-an-unopened-file () + "Boundary: previewing an org file that is NOT open harms nothing. +`org-element--cache-persist-before-write' only acts when `get-file-buffer' +finds a live buffer, so this path was never at risk and must stay cheap." + (cj--with-org-fixture real + (let* ((other (expand-file-name "other.org" (file-name-directory + (buffer-file-name real))))) + (with-temp-file other (insert "* TODO unrelated\n")) + (let ((preview (cj--test-preview-buffer other dirvish-preview-environment))) + (let (kill-buffer-query-functions) (kill-buffer preview)))) + (should-not (member nil (cj--test-cached-buffers real))))) + +(provide 'test-dirvish-config--preview-org-cache-env) +;;; test-dirvish-config--preview-org-cache-env.el ends here diff --git a/working/org-element-cache-persist-bug/control-no-preview.el b/working/org-element-cache-persist-bug/control-no-preview.el new file mode 100644 index 00000000..5f5ad3f2 --- /dev/null +++ b/working/org-element-cache-persist-bug/control-no-preview.el @@ -0,0 +1,62 @@ +;;; repro-preview-cache.el --- Does dirvish's text preview disturb an org buffer's element cache? -*- lexical-binding: t -*- + +;; Replays `dirvish--preview-file-maybe-truncate' (dirvish.el:653-684) against an +;; org file that is ALSO open for real, then kills the preview buffer the way +;; dirvish does (`dirvish--kill-buffer', dirvish.el:416). The kill is the step +;; that matters: killing an org-mode buffer with a `buffer-file-name' is when +;; org-persist writes that file's cache. + +(require 'org) +(require 'org-element) +(require 'org-persist) + +(setq org-element-use-cache t + org-element-cache-persistent t + org-element--cache-self-verify t + org-element--cache-self-verify-frequency 1.0) + +(defun repro--build-cache (buf) + "Actually populate the element cache of BUF by walking it." + (with-current-buffer buf + (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (and org-element--cache (avl-tree-size org-element--cache)))) + +(defun repro--warnings () + (when (get-buffer "*Warnings*") + (with-current-buffer "*Warnings*" (string-trim (buffer-string))))) + +(let* ((src (expand-file-name "todo.org" default-directory)) + (file (make-temp-file "repro-" nil ".org")) + (threshold 1048576)) + (copy-file src file t) + (let ((size (nth 7 (file-attributes file)))) + (message "== fixture %s (%d bytes, %s threshold) ==" + (file-name-nondirectory file) size + (if (>= size threshold) "over" "under"))) + + (let ((real (find-file-noselect file))) + (message "real buffer cache after full walk: %S" (repro--build-cache real)) + + (message "CONTROL: preview step skipped entirely") + + ;; --- dirvish kills the preview buffer when the session ends --- + (let ((kill-buffer-query-functions nil) + (preview (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (when (get-buffer preview) (kill-buffer preview)) + (message "preview buffer %S killed" preview)) + + ;; --- is the real buffer still coherent? --- + (with-current-buffer real + ;; Edit it the way Craig would after stepping back from dirvish. + (goto-char (point-max)) + (let ((inhibit-read-only t)) (insert "\n* Repro edit\n")) + (condition-case err + (progn (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (message "post-kill cache-map: clean (size=%S)" + (avl-tree-size org-element--cache))) + (error (message "post-kill cache-map: ERROR %S" err))) + (set-buffer-modified-p nil)) + + (message "warnings=%s" (or (repro--warnings) "none"))) + + (delete-file file)) diff --git a/working/org-element-cache-persist-bug/d2103877-reverted.patch b/working/org-element-cache-persist-bug/d2103877-reverted.patch new file mode 100644 index 00000000..512c6abd --- /dev/null +++ b/working/org-element-cache-persist-bug/d2103877-reverted.patch @@ -0,0 +1,199 @@ +commit d2103877f677463cbf113df951f388aaaa4a06ea +Author: Craig Jennings <c@cjennings.net> +Date: Tue Jul 28 18:25:03 2026 -0500 + + fix(dirvish): keep org previews out of the persistent element cache + + - Previewing an open .org file corrupted that file's element cache. + - The next edit to it signalled wrong-type-argument stringp nil. + - Dirvish's fallback preview claims the real file's buffer-file-name. + - set-auto-mode then makes it a second org-mode buffer. + - Killing that preview is what breaks the original buffer. + + I made the opt-out buffer-local, so real org buffers keep persistence. + + That error string is the one cj/org-clear-element-cache was written for, + so the workaround had been hiding this. + +diff --git a/modules/dirvish-config.el b/modules/dirvish-config.el +index edbb0b35..ef5966c9 100644 +--- a/modules/dirvish-config.el ++++ b/modules/dirvish-config.el +@@ -833,7 +833,41 @@ Returns nil if not in a project." + ;; No project found + (t nil))) + +- ++;;; ------------------- Dirvish Preview Org-Element Cache Opt-Out --------------- ++;; dirvish's `fallback' dispatcher previews any file it has no media handler for, ++;; and `dirvish--preview-file-maybe-truncate' builds that preview by pointing ++;; `buffer-file-name' at the real file and running `set-auto-mode'. Previewing an ++;; .org file therefore yields a SECOND org-mode buffer claiming an already-open ++;; file's name. When dirvish later kills that preview buffer, the real buffer's ++;; org-element cache is left corrupt, and the next edit to it signals ++;; `wrong-type-argument stringp nil' from `org-element--cache-after-change'. ++;; ++;; Reproduced 2026-07-28 with controls: no preview is clean, a preview left alive ++;; is clean, and the same sequence with `org-element-cache-persistent' nil is ++;; clean -- so the kill is required and the persistent cache is the mechanism. ++;; (That error string is the one `cj/org-clear-element-cache' was written for, ++;; which is how this hid for so long: the workaround was already in the config.) ++;; ++;; Opting the throwaway preview buffer out of the persistent cache is enough. It ++;; is deliberately buffer-local: the real org buffers must keep persistence. ++ ++;; A variable, not a function -- declared so the byte-compiler knows it is ++;; special without pulling org-element onto dirvish's load path. ++(defvar org-element-cache-persistent) ++ ++(defun cj/--dirvish-preview-disable-org-cache-persist () ++ "Opt a dirvish org-mode preview buffer out of the persistent element cache. ++Runs from `dirvish-preview-setup-hook' in the preview buffer. Does nothing ++outside org-mode, and nothing when `org-element-cache-persistent' is unbound -- ++a signal here would abort dirvish's preview rendering, so every branch is a ++no-op rather than an error. Returns nil." ++ (when (and (derived-mode-p 'org-mode) ++ (boundp 'org-element-cache-persistent)) ++ (setq-local org-element-cache-persistent nil)) ++ nil) ++ ++(add-hook 'dirvish-preview-setup-hook ++ #'cj/--dirvish-preview-disable-org-cache-persist) + + (provide 'dirvish-config) + ;;; dirvish-config.el ends here. +diff --git a/tests/test-dirvish-config--preview-org-cache.el b/tests/test-dirvish-config--preview-org-cache.el +new file mode 100644 +index 00000000..233b04a8 +--- /dev/null ++++ b/tests/test-dirvish-config--preview-org-cache.el +@@ -0,0 +1,129 @@ ++;;; test-dirvish-config--preview-org-cache.el --- preview org-cache opt-out tests -*- lexical-binding: t; -*- ++ ++;;; Commentary: ++;; Dirvish's fallback preview builds a buffer, points `buffer-file-name' at the ++;; real file, and runs `set-auto-mode' -- so previewing an .org file yields a ++;; second org-mode buffer claiming an open file's name. Killing that preview ++;; buffer corrupted the real buffer's element cache, surfacing as ++;; `wrong-type-argument stringp nil' on the next edit. Reproduced 2026-07-28 ++;; with controls: the kill is required, and `org-element-cache-persistent' is ++;; the mechanism (nil made the same sequence clean). ++;; ++;; `cj/--dirvish-preview-disable-org-cache-persist' opts the preview buffer out ++;; of the persistent cache, buffer-locally, leaving the real buffer alone. ++ ++;;; Code: ++ ++(require 'ert) ++(require 'org-element) ++(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) ++(require 'dirvish-config) ++ ++(declare-function cj/--dirvish-preview-disable-org-cache-persist "dirvish-config" ()) ++ ++;;; ----------------------------- Normal cases --------------------------------- ++ ++(ert-deftest test-dirvish-preview-org-cache-disables-in-org-buffer () ++ "Normal: an org-mode preview buffer opts out of the persistent cache." ++ (with-temp-buffer ++ (delay-mode-hooks (org-mode)) ++ (cj/--dirvish-preview-disable-org-cache-persist) ++ (should (local-variable-p 'org-element-cache-persistent)) ++ (should-not org-element-cache-persistent))) ++ ++(ert-deftest test-dirvish-preview-org-cache-leaves-global-alone () ++ "Normal: the opt-out is buffer-local and never touches the global value. ++The real org buffers must keep their persistent cache; only the throwaway ++preview buffer opts out. Asserting the global default explicitly is the point ++of this test -- a buffer-local set that leaked to the default would disable ++persistence everywhere and still pass every other test here." ++ (let ((original (default-value 'org-element-cache-persistent))) ++ (unwind-protect ++ (progn ++ (setq-default org-element-cache-persistent t) ++ (with-temp-buffer ++ (delay-mode-hooks (org-mode)) ++ (cj/--dirvish-preview-disable-org-cache-persist) ++ (should-not org-element-cache-persistent)) ++ ;; The default survived the buffer-local set. ++ (should (eq (default-value 'org-element-cache-persistent) t)) ++ ;; And a fresh org buffer still inherits persistence. ++ (with-temp-buffer ++ (delay-mode-hooks (org-mode)) ++ (should org-element-cache-persistent))) ++ (setq-default org-element-cache-persistent original)))) ++ ++;;; ---------------------------- Boundary cases -------------------------------- ++ ++(ert-deftest test-dirvish-preview-org-cache-ignores-non-org-buffer () ++ "Boundary: a non-org preview buffer is left completely alone." ++ (with-temp-buffer ++ (fundamental-mode) ++ (cj/--dirvish-preview-disable-org-cache-persist) ++ (should-not (local-variable-p 'org-element-cache-persistent)))) ++ ++(ert-deftest test-dirvish-preview-org-cache-covers-derived-mode () ++ "Boundary: a mode derived from org-mode still opts out. ++The check is `derived-mode-p', not an `eq' on `major-mode', so org derivatives ++previewed by dirvish are covered too." ++ (with-temp-buffer ++ (delay-mode-hooks (org-mode)) ++ (define-derived-mode cj-test-org-derived-mode org-mode "TestOrg" ++ "Throwaway org derivative for this test.") ++ (delay-mode-hooks (cj-test-org-derived-mode)) ++ (cj/--dirvish-preview-disable-org-cache-persist) ++ (should (local-variable-p 'org-element-cache-persistent)) ++ (should-not org-element-cache-persistent))) ++ ++(ert-deftest test-dirvish-preview-org-cache-is-idempotent () ++ "Boundary: running twice in one buffer is a no-op the second time." ++ (with-temp-buffer ++ (delay-mode-hooks (org-mode)) ++ (cj/--dirvish-preview-disable-org-cache-persist) ++ (cj/--dirvish-preview-disable-org-cache-persist) ++ (should (local-variable-p 'org-element-cache-persistent)) ++ (should-not org-element-cache-persistent))) ++ ++;;; ------------------------------ Error cases --------------------------------- ++ ++(ert-deftest test-dirvish-preview-org-cache-survives-missing-variable () ++ "Error: no signal when `org-element-cache-persistent' is not bound. ++The function runs from a dirvish hook; an error there would break preview ++rendering, so a missing org internal must degrade to a no-op. ++ ++Drives real state rather than mocking `boundp'. `boundp' is a C primitive, and ++redefining one is unreliable under native-comp -- a natively-compiled caller can ++run the real primitive through a trampoline and quietly ignore the mock, which ++would turn this into a test that passes without exercising the guard. Org-mode ++is entered before the unbind so mode setup never reads the missing variable." ++ (let* ((bound (boundp 'org-element-cache-persistent)) ++ (original (and bound (default-value 'org-element-cache-persistent)))) ++ (unwind-protect ++ (with-temp-buffer ++ (delay-mode-hooks (org-mode)) ++ (makunbound 'org-element-cache-persistent) ++ (should-not (boundp 'org-element-cache-persistent)) ++ (should-not (cj/--dirvish-preview-disable-org-cache-persist)) ++ ;; The guard declined to create a binding rather than erroring. ++ (should-not (local-variable-p 'org-element-cache-persistent))) ++ (when bound (setq-default org-element-cache-persistent original))))) ++ ++(ert-deftest test-dirvish-preview-org-cache-runs-in-a-fileless-buffer () ++ "Error: a buffer with no `buffer-file-name' is handled without signalling." ++ (with-temp-buffer ++ (delay-mode-hooks (org-mode)) ++ (should-not (buffer-file-name)) ++ (cj/--dirvish-preview-disable-org-cache-persist) ++ (should-not org-element-cache-persistent))) ++ ++;;; ----------------------------- Registration --------------------------------- ++ ++(ert-deftest test-dirvish-preview-org-cache-hook-registered () ++ "Normal: the opt-out is on `dirvish-preview-setup-hook'. ++Registration is the half that makes the fix reach dirvish at all -- the ++function being correct is useless if nothing calls it." ++ (should (memq 'cj/--dirvish-preview-disable-org-cache-persist ++ (default-value 'dirvish-preview-setup-hook)))) ++ ++(provide 'test-dirvish-config--preview-org-cache) ++;;; test-dirvish-config--preview-org-cache.el ends here diff --git a/working/org-element-cache-persist-bug/hostile-a-errorbranch.el b/working/org-element-cache-persist-bug/hostile-a-errorbranch.el new file mode 100644 index 00000000..88711787 --- /dev/null +++ b/working/org-element-cache-persist-bug/hostile-a-errorbranch.el @@ -0,0 +1,76 @@ +;;; hostile-a-errorbranch.el --- attack the dirvish.el:680 error branch -*- lexical-binding: t -*- + +;; dirvish--preview-file-maybe-truncate (dirvish.el:671-680) wraps +;; (set-auto-mode) (font-lock-mode 1) (and so-long-detected-p (error ...)) +;; in a condition-case. On ANY error the buffer is KILLED at line 680 and +;; `dirvish-preview-setup-hook' at line 682 is NEVER reached. By then +;; set-auto-mode has already put the buffer in org-mode with buffer-file-name +;; pointing at the real file. So the shipped fix cannot run on that path. + +(require 'org) (require 'org-element) (require 'org-persist) +(add-to-list 'load-path (expand-file-name "modules" default-directory)) +(require 'dirvish-config) + +(setq org-element-use-cache t + org-element-cache-persistent t + org-element--cache-self-verify t + org-element--cache-self-verify-frequency 1.0) + +(defun h--walk (buf) + (with-current-buffer buf + (org-element-cache-map (lambda (_e) nil) :granularity 'element) + (and org-element--cache (avl-tree-size org-element--cache)))) + +;; Faithful replay of dirvish.el:657-684, including the condition-case and the +;; error-branch kill. ERROR-INJECT non-nil simulates so-long-detected-p / any +;; other signal raised AFTER set-auto-mode has entered org-mode. +(defun h--preview (file error-inject) + (with-current-buffer (get-buffer-create "*preview-temp*") + (let ((threshold 1048576) info jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) + (insert-file-contents file nil 0 threshold) + (setq buffer-file-name file) + (goto-char (point-min)) + (rename-buffer (format "PREVIEW :: 999 :: %s" (file-name-nondirectory file)))) + (condition-case err + (let ((enable-dir-local-variables nil) (enable-local-variables :safe) + (non-essential t) (inhibit-message t)) + (setq-local delay-mode-hooks t) + (set-auto-mode) (font-lock-mode 1) + (and error-inject (error "No preview of file with long lines"))) + (error (setq info (error-message-string err)))) + (message " preview: mode=%s file=%s persist-local=%s registered-kill-hook=%s" + major-mode (and buffer-file-name t) + (local-variable-p 'org-element-cache-persistent) + (and (memq 'org-persist-write-all-buffer kill-buffer-hook) t)) + (if info + (progn (message " ERROR BRANCH taken (%s) -> kill WITHOUT hook" info) + (let (kill-buffer-query-functions) (kill-buffer (current-buffer)))) + (run-hooks 'dirvish-preview-setup-hook) + (message " ok branch: hook ran, persist-local=%s value=%s" + (local-variable-p 'org-element-cache-persistent) + org-element-cache-persistent) + (let (kill-buffer-query-functions) (kill-buffer (current-buffer))))))) + +(defun h--trial (label error-inject) + (let* ((src (expand-file-name "todo.org" default-directory)) + (file (make-temp-file "hostile-" nil ".org"))) + (copy-file src file t) + (message "== %s ==" label) + (let ((real (find-file-noselect file))) + (message " real cache: %S" (h--walk real)) + (h--preview file error-inject) + (with-current-buffer real + (goto-char (point-max)) + (condition-case err + (progn (let ((inhibit-read-only t)) (insert "\n* Hostile edit\n")) + (org-element-cache-map (lambda (_e) nil) :granularity 'element) + (message " RESULT: CLEAN (size=%S)" (avl-tree-size org-element--cache))) + (error (message " RESULT: CORRUPT -> %S" err))) + (set-buffer-modified-p nil)) + (let (kill-buffer-query-functions) (kill-buffer real))) + (delete-file file))) + +(h--trial "control: no error, hook runs (shipped fix active)" nil) +(h--trial "attack: error after set-auto-mode -> hook skipped" t) diff --git a/working/org-element-cache-persist-bug/hostile-c-repro.el b/working/org-element-cache-persist-bug/hostile-c-repro.el new file mode 100644 index 00000000..17627e63 --- /dev/null +++ b/working/org-element-cache-persist-bug/hostile-c-repro.el @@ -0,0 +1,32 @@ +;;; -*- lexical-binding: t -*- +(setq org-persist-directory (expand-file-name "hostile-c-persist" default-directory)) +(require 'org) +(require 'org-element) +(require 'org-persist) +(let* ((f (expand-file-name "hostile-c-real.org" default-directory))) + (with-temp-file f (insert "* Head one\nbody\n* Head two\n")) + ;; 1. the REAL buffer, as Craig has open + (let ((real (find-file-noselect f))) + (with-current-buffer real (org-element-at-point (point-max))) + (princ (format "real registered: %S\n" + (and (org-persist--find-index + `(:container ,(org-persist--normalize-container + `((elisp org-element--cache) (version ,org-element-cache-version))) + :associated ,(org-persist--normalize-associated real))) + t))) + ;; 2. dirvish preview: second org buffer claiming the same file name + (let ((prev (get-buffer-create "PREVIEW :: hostile-c-real.org"))) + (with-current-buffer prev + (insert-file-contents f) + (setq buffer-file-name f) + (delay-mode-hooks (org-mode)) + ;; the commit's hook + (setq-local org-element-cache-persistent nil) + ;; 3. anything that resets the cache in this live preview buffer + (org-element-cache-reset)) + (princ (format "real registered AFTER preview reset: %S\n" + (and (org-persist--find-index + `(:container ,(org-persist--normalize-container + `((elisp org-element--cache) (version ,org-element-cache-version))) + :associated ,(org-persist--normalize-associated real))) + t)))))) diff --git a/working/org-element-cache-persist-bug/hostile-d-faithful.el b/working/org-element-cache-persist-bug/hostile-d-faithful.el new file mode 100644 index 00000000..bbd0aecb --- /dev/null +++ b/working/org-element-cache-persist-bug/hostile-d-faithful.el @@ -0,0 +1,48 @@ +;; Faithful replay: real dirvish env incl. delay-mode-hooks, inhibit-message, +;; timestamped buffer name, preview-hash text reuse, dirvish--kill-buffer shape. +(require 'cl-lib) (require 'org) (require 'org-element) (require 'org-persist) +(when (getenv "FIX") + (add-to-list 'load-path (expand-file-name "modules" default-directory)) + (require 'dirvish-config)) +(setq org-element-use-cache t org-element-cache-persistent t) +(defvar hash (make-hash-table :test 'equal)) +(defun nilbuf (b) (with-current-buffer b + (let ((k 0)) (avl-tree-mapc (lambda (e) (unless (org-element-property :buffer e) (cl-incf k))) org-element--cache) k))) +(defun preview (file name) + (with-current-buffer (get-buffer-create "*preview-temp*") + (let ((text (gethash file hash)) info jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) + (if text (insert text) (insert-file-contents file nil 0 1048576)) + (setq buffer-file-name file) (goto-char (point-min)) + (rename-buffer name)) + (condition-case err + (eval `(let ((inhibit-message t) (non-essential t) + (enable-dir-local-variables nil) (enable-local-variables :safe)) + (setq-local delay-mode-hooks t) + (set-auto-mode) (font-lock-mode 1))) + (error (setq info (error-message-string err)))) + (if info (message ">> preview aborted: %s" info) + (run-hooks 'dirvish-preview-setup-hook) + (unless text (puthash file (buffer-string) hash))) + (message ">> preview mode=%s delay-mode-hooks=%S persist=%S" + major-mode delay-mode-hooks org-element-cache-persistent) + (current-buffer)))) +(defun dv-kill (b) (and (buffer-live-p b) (let (kill-buffer-query-functions) (kill-buffer b)))) +(let* ((file (make-temp-file "fa-" nil ".org"))) + (copy-file (expand-file-name "todo.org" default-directory) file t) + (let ((real (find-file-noselect file))) + (with-current-buffer real (org-element-cache-map (lambda (_) nil) :granularity 'element)) + (message ">> real nil-buffer before=%d" (nilbuf real)) + ;; pass 1 + (dv-kill (preview file (format "PREVIEW :: %s :: %s" "1753000000" (file-name-nondirectory file)))) + (message ">> after pass1 kill nil-buffer=%d gfb=%S" (nilbuf real) (buffer-name (get-file-buffer file))) + ;; pass 2 (hash hit: text branch) + (dv-kill (preview file (format "PREVIEW :: %s :: %s" "1753000001" (file-name-nondirectory file)))) + (message ">> after pass2 kill nil-buffer=%d" (nilbuf real)) + (with-current-buffer real + (goto-char (point-max)) + (condition-case err (let ((inhibit-read-only t)) (insert "\n* E\n")) + (error (message ">> RESULT: SIGNALLED %S" err))) + (message ">> edit completed") (set-buffer-modified-p nil))) + (delete-file file)) diff --git a/working/org-element-cache-persist-bug/hostile-d-nopreview.el b/working/org-element-cache-persist-bug/hostile-d-nopreview.el new file mode 100644 index 00000000..91ae1ce7 --- /dev/null +++ b/working/org-element-cache-persist-bug/hostile-d-nopreview.el @@ -0,0 +1,23 @@ +(require 'cl-lib) (require 'org) (require 'org-element) (require 'org-persist) +(setq org-element-use-cache t org-element-cache-persistent t) +(when (getenv "SV") (setq org-element--cache-self-verify t org-element--cache-self-verify-frequency 1.0)) +(defun nilbuf (buf) (with-current-buffer buf + (let ((k 0)) (avl-tree-mapc (lambda (el) (unless (org-element-property :buffer el) (cl-incf k))) org-element--cache) k))) +(let* ((file (make-temp-file "np-" nil ".org"))) + (copy-file (expand-file-name "todo.org" default-directory) file t) + (let ((real (find-file-noselect file))) + (with-current-buffer real (org-element-cache-map (lambda (_) nil) :granularity 'element)) + (message ">> before: nil-buffer=%d" (nilbuf real)) + (message ">> MODE=%s" (getenv "MODE")) + (pcase (getenv "MODE") + ("writeall" (org-persist-write-all)) + ("writebuf" (with-current-buffer real (org-persist-write-all-buffer))) + (_ nil)) + (message ">> after trigger: nil-buffer=%d" (nilbuf real)) + (with-current-buffer real + (goto-char (point-max)) + (condition-case err (let ((inhibit-read-only t)) (insert "\n* Edit\n")) + (error (message ">> RESULT: insert SIGNALLED %S" err))) + (message ">> insert survived (nil-buffer=%d)" (nilbuf real)) + (set-buffer-modified-p nil))) + (delete-file file)) diff --git a/working/org-element-cache-persist-bug/hostile-d-order.el b/working/org-element-cache-persist-bug/hostile-d-order.el new file mode 100644 index 00000000..898e90fe --- /dev/null +++ b/working/org-element-cache-persist-bug/hostile-d-order.el @@ -0,0 +1,30 @@ +(require 'cl-lib) (require 'org) (require 'org-element) (require 'org-persist) +(setq org-element-use-cache t org-element-cache-persistent t) +(defun nilbuf (buf) (with-current-buffer buf + (let ((k 0)) (avl-tree-mapc (lambda (el) (unless (org-element-property :buffer el) (cl-incf k))) org-element--cache) k))) +(let* ((file (make-temp-file "ord-" nil ".org"))) + (copy-file (expand-file-name "todo.org" default-directory) file t) + (let ((real (find-file-noselect file))) + (with-current-buffer real (org-element-cache-map (lambda (_) nil) :granularity 'element)) + (with-current-buffer (get-buffer-create "*preview-temp*") + (let (jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) (insert-file-contents file nil 0 1048576) + (setq buffer-file-name file) (goto-char (point-min)) (rename-buffer "PREVIEW")) + (let ((enable-dir-local-variables nil) (enable-local-variables :safe) (non-essential t)) + (set-auto-mode) (font-lock-mode 1))) + (org-element-cache-map (lambda (_) nil) :granularity 'element)) + (when (equal (getenv "BURY") "1") + (bury-buffer real) + (message ">> buried real")) + (message ">> get-file-buffer -> %S (buffer-list head: %S)" + (buffer-name (get-file-buffer file)) + (mapcar #'buffer-name (seq-take (buffer-list) 4))) + (let ((kill-buffer-query-functions nil)) (kill-buffer "PREVIEW")) + (message ">> after kill nil-buffer=%d" (nilbuf real)) + (with-current-buffer real + (goto-char (point-max)) + (condition-case err (let ((inhibit-read-only t)) (insert "\n* E\n")) + (error (message ">> RESULT: SIGNALLED %S" err))) + (message ">> done") (set-buffer-modified-p nil))) + (delete-file file)) diff --git a/working/org-element-cache-persist-bug/hostile-e-ffnoselect.el b/working/org-element-cache-persist-bug/hostile-e-ffnoselect.el new file mode 100644 index 00000000..b4c474ba --- /dev/null +++ b/working/org-element-cache-persist-bug/hostile-e-ffnoselect.el @@ -0,0 +1,8 @@ +(let ((f (make-temp-file "h-e-" nil ".org"))) + (with-temp-file f (insert "* real\n")) + (let* ((real (find-file-noselect f)) + (temp (cdr `(buffer . ,(eval `(let ((vc-follow-symlinks t) (find-file-hook nil)) + (find-file-noselect ,f 'nowarn))))))) + (message "find-file-temporarily returned the USER'S buffer: %s (same=%s) name=%s" + (buffer-name temp) (eq real temp) (buffer-name real))) + (delete-file f)) diff --git a/working/org-element-cache-persist-bug/refute-fontify-rearms.el b/working/org-element-cache-persist-bug/refute-fontify-rearms.el new file mode 100644 index 00000000..fd55194b --- /dev/null +++ b/working/org-element-cache-persist-bug/refute-fontify-rearms.el @@ -0,0 +1,49 @@ +;; Does the preview buffer re-register after the let unwinds, on fontification? +(require 'org) (require 'org-element) (require 'org-persist) +(defvar rk-dir (make-temp-file "refute-" t)) +(setq org-persist-directory (expand-file-name "persist" rk-dir)) +(setq org-element-use-cache t org-element-cache-persistent t org-log-done nil) +(defvar rk-file (expand-file-name "notes.org" rk-dir)) +(with-temp-file rk-file + (dotimes (i 20) (insert (format "* TODO task %d\nbody with src_python{1+1} inline\n" i)))) + +(defun rk-bufs (buf) + (with-current-buffer buf + (let (s) (avl-tree-mapc (lambda (el) (push (org-element-property :buffer el) s)) + org-element--cache) + (delete-dups s)))) + +(let ((real (find-file-noselect rk-file))) + (with-current-buffer real + (org-element-cache-reset) + (org-element-cache-map #'ignore :granularity 'headline) + (goto-char (point-min)) (re-search-forward "^\\* TODO task 0") (beginning-of-line) + (org-todo "DONE")) + (message "before: %S" (rk-bufs real)) + ;; preview WITH the fix's environment, then let it LIVE and fontify (the step my tests skip) + (let ((prev (get-buffer-create "*prev*"))) + (with-current-buffer prev + (with-silent-modifications + (insert-file-contents rk-file nil 0 1048576) + (setq buffer-file-name rk-file)) + (eval `(let ((inhibit-message t) (non-essential t) + (enable-dir-local-variables nil) (enable-local-variables :safe) + (org-element-use-cache nil)) + (setq-local delay-mode-hooks t) (set-auto-mode) (font-lock-mode 1))) + (message "after set-auto-mode: local-cache=%S global=%S persist-hook=%S" + org-element-use-cache (default-value 'org-element-use-cache) + (and (memq 'org-persist-write-all-buffer kill-buffer-hook) t)) + ;; THE MISSING STEP: the preview lives in a window and gets fontified + (font-lock-ensure) + (message "after fontify: persist-hook=%S cache-active=%S" + (and (memq 'org-persist-write-all-buffer kill-buffer-hook) t) + (org-element--cache-active-p))) + (let (kill-buffer-query-functions) (kill-buffer prev))) + (message "after kill: %S" (rk-bufs real)) + (with-current-buffer real + (message "parse => %s" + (condition-case e (progn (org-element-cache-map + (lambda (el) (org-element-property :raw-value el)) + :granularity 'headline) "OK") + (error (format "ERROR %S" e)))))) +(delete-directory rk-dir t) diff --git a/working/org-element-cache-persist-bug/repro-preview-cache.el b/working/org-element-cache-persist-bug/repro-preview-cache.el new file mode 100644 index 00000000..2a527af1 --- /dev/null +++ b/working/org-element-cache-persist-bug/repro-preview-cache.el @@ -0,0 +1,88 @@ +;;; repro-preview-cache.el --- Does dirvish's text preview disturb an org buffer's element cache? -*- lexical-binding: t -*- + +;; Replays `dirvish--preview-file-maybe-truncate' (dirvish.el:653-684) against an +;; org file that is ALSO open for real, then kills the preview buffer the way +;; dirvish does (`dirvish--kill-buffer', dirvish.el:416). The kill is the step +;; that matters: killing an org-mode buffer with a `buffer-file-name' is when +;; org-persist writes that file's cache. + +(require 'org) +(require 'org-element) +(require 'org-persist) + +(setq org-element-use-cache t + org-element-cache-persistent t + org-element--cache-self-verify t + org-element--cache-self-verify-frequency 1.0) + +(defun repro--build-cache (buf) + "Actually populate the element cache of BUF by walking it." + (with-current-buffer buf + (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (and org-element--cache (avl-tree-size org-element--cache)))) + +(defun repro--warnings () + (when (get-buffer "*Warnings*") + (with-current-buffer "*Warnings*" (string-trim (buffer-string))))) + +(let* ((src (expand-file-name "todo.org" default-directory)) + (file (make-temp-file "repro-" nil ".org")) + (threshold 1048576)) + (copy-file src file t) + (let ((size (nth 7 (file-attributes file)))) + (message "== fixture %s (%d bytes, %s threshold) ==" + (file-name-nondirectory file) size + (if (>= size threshold) "over" "under"))) + + (let ((real (find-file-noselect file))) + (message "real buffer cache after full walk: %S" (repro--build-cache real)) + + ;; --- dirvish text preview of the same file --- + (with-current-buffer (get-buffer-create "*preview-temp*") + (let (jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) + (insert-file-contents file nil 0 threshold) + (when (>= (nth 7 (file-attributes file)) threshold) + (goto-char (point-max)) + (insert "\n\nFile truncated. End of partial preview.\n")) + (setq buffer-file-name file) + (goto-char (point-min)) + (rename-buffer (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (let ((enable-dir-local-variables nil) + (enable-local-variables :safe) + (non-essential t)) + (set-auto-mode) + (font-lock-mode 1))) + (message "preview buffer: mode=%s claims=%s cache=%S" + major-mode (file-name-nondirectory (or buffer-file-name "none")) + (repro--build-cache (current-buffer)))) + + (message "-- both buffers live: real=%S claiming-file=%d --" + (with-current-buffer real (avl-tree-size org-element--cache)) + (length (seq-filter (lambda (b) (equal (buffer-local-value 'buffer-file-name b) file)) + (buffer-list)))) + + ;; --- dirvish kills the preview buffer when the session ends --- + (let ((kill-buffer-query-functions nil) + (preview (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (kill-buffer preview) + (message "preview buffer %S killed" preview)) + + ;; --- is the real buffer still coherent? --- + (with-current-buffer real + ;; Edit it the way Craig would after stepping back from dirvish. + (goto-char (point-max)) + (condition-case err + (let ((inhibit-read-only t)) (insert "\n* Repro edit\n")) + (error (message "RESULT: insert into real buffer SIGNALLED %S" (car err)))) + (condition-case err + (progn (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (message "post-kill cache-map: clean (size=%S)" + (avl-tree-size org-element--cache))) + (error (message "post-kill cache-map: ERROR %S" err))) + (set-buffer-modified-p nil)) + + (message "warnings=%s" (or (repro--warnings) "none"))) + + (delete-file file)) diff --git a/working/org-element-cache-persist-bug/upstream-report.txt b/working/org-element-cache-persist-bug/upstream-report.txt new file mode 100644 index 00000000..81fcaaa7 --- /dev/null +++ b/working/org-element-cache-persist-bug/upstream-report.txt @@ -0,0 +1,87 @@ +Subject: [BUG] Persisting the element cache while its buffer is live corrupts it [9.7.11 (release_9.7.11 @ /usr/share/emacs/30.2/lisp/org/)] + +Writing the element cache to disk strips the :buffer property from every cached +element in the live buffer and never puts it back. The next access to a cached +headline signals (wrong-type-argument stringp nil), and it keeps signalling until +the cache is reset by hand. + +Minimal reproduction, self-contained, no dirvish or other packages involved. Save +as repro.el and run "emacs -Q --batch -l repro.el": + + (require 'org) + (require 'org-element) + (require 'org-persist) + + (let* ((dir (make-temp-file "org-persist-repro-" t)) + (org-persist-directory (expand-file-name "persist" dir)) + (file (expand-file-name "notes.org" dir)) + (org-element-use-cache t) + (org-element-cache-persistent t) + (org-log-done nil)) + (with-temp-file file + (dotimes (i 20) (insert (format "* TODO task %d\nbody %d\n" i i)))) + (let ((buffer (find-file-noselect file))) + (with-current-buffer buffer + (org-element-cache-reset) + (org-element-cache-map #'ignore :granularity 'headline) + (goto-char (point-min)) + (re-search-forward "^\\* TODO task 0") + (beginning-of-line) + (org-todo "DONE")) + (org-persist-write `((elisp org-element--cache) + (version ,org-element-cache-version)) + buffer t) + (with-current-buffer buffer + (message "%S" + (condition-case err + (progn (org-element-cache-map + (lambda (e) (org-element-property :raw-value e)) + :granularity 'headline) + "ok") + (error err)))) + (set-buffer-modified-p nil) + (kill-buffer buffer)) + (delete-directory dir t)) + +Expected: "ok". +Actual: (wrong-type-argument stringp nil). + +Adding a print of the cached :buffer values on either side of the write shows +(#<buffer notes.org>) before and (nil) after. + +The mechanism, as far as I can follow it. org-element--cache-persist-before-write +walks org-element--cache and clears :buffer on every element. That looks +deliberate, since buffer objects can't be printed, and a8286a5a9 describes it as +"Clear and restore non-printable buffer objects in :buffer property". The restore +half is org-element--cache-persist-after-read, which sets :buffer back to +(current-buffer). But that only runs on the read path. Nothing restores :buffer +after a write, so a write against a buffer that is still alive leaves the live +cache holding nils. + +The error itself comes from org-element--headline-parse-title. Cached elements +keep their deferred :title and :tags thunks, and resolving one runs +(with-current-buffer (org-element-property :buffer headline)). set-buffer on nil +is the signal. + +How I reached it without calling org-persist-write directly. Any second buffer +visiting the same file will do it, because org-persist registers a buffer-local +org-persist-write-all-buffer on kill-buffer-hook, and the write's hook resolves +(get-file-buffer FILE), which can return the other buffer. In my case dirvish +built a preview buffer, pointed buffer-file-name at a file I already had open, +and ran set-auto-mode. Killing that preview corrupted the cache of the buffer I +was working in. Any package that makes a throwaway buffer visiting a live file +can trigger it, so I don't think this is dirvish's bug to fix. + +Two details that might help narrow it. Which buffer gets damaged depends on +buffer-list order, since get-file-buffer returns the first buffer visiting the +file. And a nearly empty cache survives, because the next access reparses instead +of reading a stripped element. That combination is probably why this shows up as +an intermittent "org-element cache is broken again" rather than a clean repro. + +Setting org-element-cache-persistent to nil avoids it, which I see recommended on +this list fairly often. It looks like it may be working around this rather than a +separate problem. + +I haven't written a patch. From the outside the symmetric fix would be to restore +:buffer after an in-session write the way the read path does, rather than to stop +clearing it. Happy to test a patch against the reproduction above. diff --git a/working/org-element-cache-persist-bug/upstream-repro.el b/working/org-element-cache-persist-bug/upstream-repro.el new file mode 100644 index 00000000..d0a96774 --- /dev/null +++ b/working/org-element-cache-persist-bug/upstream-repro.el @@ -0,0 +1,70 @@ +;;; upstream-repro.el --- minimal reproduction for the org list -*- lexical-binding: t -*- + +;; Run with: emacs -Q --batch -l upstream-repro.el +;; +;; Writing the element cache to disk while the buffer is still live strips the +;; :buffer property from every cached element and never restores it. The next +;; access to a cached headline signals (wrong-type-argument stringp nil). + +(require 'org) +(require 'org-element) +(require 'org-persist) + +(let* ((dir (make-temp-file "org-persist-repro-" t)) + (org-persist-directory (expand-file-name "persist" dir)) + (file (expand-file-name "notes.org" dir)) + (org-element-use-cache t) + (org-element-cache-persistent t) + (org-log-done nil)) + + (with-temp-file file + (dotimes (i 20) + (insert (format "* TODO task %d\nbody %d\n" i i)))) + + (let ((buffer (find-file-noselect file))) + (with-current-buffer buffer + ;; Populate the cache with parsed headlines. + (org-element-cache-reset) + (org-element-cache-map #'ignore :granularity 'headline) + (goto-char (point-min)) + (re-search-forward "^\\* TODO task 0") + (beginning-of-line) + (org-todo "DONE")) + + (message "cached :buffer values before write: %S" + (with-current-buffer buffer + (let (values) + (avl-tree-mapc (lambda (element) + (push (org-element-property :buffer element) values)) + org-element--cache) + (delete-dups values)))) + + ;; Persist while the buffer is still alive. In a real session this is + ;; reached by any in-session write, e.g. `org-persist-write-all-buffer' from + ;; `kill-buffer-hook' in a *second* buffer visiting the same file. + (org-persist-write `((elisp org-element--cache) + (version ,org-element-cache-version)) + buffer t) + + (message "cached :buffer values after write: %S" + (with-current-buffer buffer + (let (values) + (avl-tree-mapc (lambda (element) + (push (org-element-property :buffer element) values)) + org-element--cache) + (delete-dups values)))) + + (with-current-buffer buffer + (message "reading a cached headline: %s" + (condition-case err + (progn (org-element-cache-map + (lambda (element) (org-element-property :raw-value element)) + :granularity 'headline) + "ok") + (error (format "%S" err))))) + + (set-buffer-modified-p nil) + (kill-buffer buffer)) + (delete-directory dir t)) + +;;; upstream-repro.el ends here diff --git a/working/org-element-cache-persist-bug/variant-no-kill.el b/working/org-element-cache-persist-bug/variant-no-kill.el new file mode 100644 index 00000000..180f6cd2 --- /dev/null +++ b/working/org-element-cache-persist-bug/variant-no-kill.el @@ -0,0 +1,88 @@ +;;; repro-preview-cache.el --- Does dirvish's text preview disturb an org buffer's element cache? -*- lexical-binding: t -*- + +;; Replays `dirvish--preview-file-maybe-truncate' (dirvish.el:653-684) against an +;; org file that is ALSO open for real, then kills the preview buffer the way +;; dirvish does (`dirvish--kill-buffer', dirvish.el:416). The kill is the step +;; that matters: killing an org-mode buffer with a `buffer-file-name' is when +;; org-persist writes that file's cache. + +(require 'org) +(require 'org-element) +(require 'org-persist) + +(setq org-element-use-cache t + org-element-cache-persistent t + org-element--cache-self-verify t + org-element--cache-self-verify-frequency 1.0) + +(defun repro--build-cache (buf) + "Actually populate the element cache of BUF by walking it." + (with-current-buffer buf + (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (and org-element--cache (avl-tree-size org-element--cache)))) + +(defun repro--warnings () + (when (get-buffer "*Warnings*") + (with-current-buffer "*Warnings*" (string-trim (buffer-string))))) + +(let* ((src (expand-file-name "todo.org" default-directory)) + (file (make-temp-file "repro-" nil ".org")) + (threshold 1048576)) + (copy-file src file t) + (let ((size (nth 7 (file-attributes file)))) + (message "== fixture %s (%d bytes, %s threshold) ==" + (file-name-nondirectory file) size + (if (>= size threshold) "over" "under"))) + + (let ((real (find-file-noselect file))) + (message "real buffer cache after full walk: %S" (repro--build-cache real)) + + ;; --- dirvish text preview of the same file --- + (with-current-buffer (get-buffer-create "*preview-temp*") + (let (jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) + (insert-file-contents file nil 0 threshold) + (when (>= (nth 7 (file-attributes file)) threshold) + (goto-char (point-max)) + (insert "\n\nFile truncated. End of partial preview.\n")) + (setq buffer-file-name file) + (goto-char (point-min)) + (rename-buffer (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (let ((enable-dir-local-variables nil) + (enable-local-variables :safe) + (non-essential t)) + (set-auto-mode) + (font-lock-mode 1))) + (message "preview buffer: mode=%s claims=%s cache=%S" + major-mode (file-name-nondirectory (or buffer-file-name "none")) + (repro--build-cache (current-buffer)))) + + (message "-- both buffers live: real=%S claiming-file=%d --" + (with-current-buffer real (avl-tree-size org-element--cache)) + (length (seq-filter (lambda (b) (equal (buffer-local-value 'buffer-file-name b) file)) + (buffer-list)))) + + ;; --- dirvish kills the preview buffer when the session ends --- + (let ((kill-buffer-query-functions nil) + (preview (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (ignore preview) + (message "VARIANT: preview buffer left ALIVE")) + + ;; --- is the real buffer still coherent? --- + (with-current-buffer real + ;; Edit it the way Craig would after stepping back from dirvish. + (goto-char (point-max)) + (condition-case err + (let ((inhibit-read-only t)) (insert "\n* Repro edit\n")) + (error (message "RESULT: insert into real buffer SIGNALLED %S" (car err)))) + (condition-case err + (progn (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (message "post-kill cache-map: clean (size=%S)" + (avl-tree-size org-element--cache))) + (error (message "post-kill cache-map: ERROR %S" err))) + (set-buffer-modified-p nil)) + + (message "warnings=%s" (or (repro--warnings) "none"))) + + (delete-file file)) diff --git a/working/org-element-cache-persist-bug/variant-no-persist.el b/working/org-element-cache-persist-bug/variant-no-persist.el new file mode 100644 index 00000000..75c85bc6 --- /dev/null +++ b/working/org-element-cache-persist-bug/variant-no-persist.el @@ -0,0 +1,88 @@ +;;; repro-preview-cache.el --- Does dirvish's text preview disturb an org buffer's element cache? -*- lexical-binding: t -*- + +;; Replays `dirvish--preview-file-maybe-truncate' (dirvish.el:653-684) against an +;; org file that is ALSO open for real, then kills the preview buffer the way +;; dirvish does (`dirvish--kill-buffer', dirvish.el:416). The kill is the step +;; that matters: killing an org-mode buffer with a `buffer-file-name' is when +;; org-persist writes that file's cache. + +(require 'org) +(require 'org-element) +(require 'org-persist) + +(setq org-element-use-cache t + org-element-cache-persistent nil + org-element--cache-self-verify t + org-element--cache-self-verify-frequency 1.0) + +(defun repro--build-cache (buf) + "Actually populate the element cache of BUF by walking it." + (with-current-buffer buf + (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (and org-element--cache (avl-tree-size org-element--cache)))) + +(defun repro--warnings () + (when (get-buffer "*Warnings*") + (with-current-buffer "*Warnings*" (string-trim (buffer-string))))) + +(let* ((src (expand-file-name "todo.org" default-directory)) + (file (make-temp-file "repro-" nil ".org")) + (threshold 1048576)) + (copy-file src file t) + (let ((size (nth 7 (file-attributes file)))) + (message "== fixture %s (%d bytes, %s threshold) ==" + (file-name-nondirectory file) size + (if (>= size threshold) "over" "under"))) + + (let ((real (find-file-noselect file))) + (message "real buffer cache after full walk: %S" (repro--build-cache real)) + + ;; --- dirvish text preview of the same file --- + (with-current-buffer (get-buffer-create "*preview-temp*") + (let (jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) + (insert-file-contents file nil 0 threshold) + (when (>= (nth 7 (file-attributes file)) threshold) + (goto-char (point-max)) + (insert "\n\nFile truncated. End of partial preview.\n")) + (setq buffer-file-name file) + (goto-char (point-min)) + (rename-buffer (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (let ((enable-dir-local-variables nil) + (enable-local-variables :safe) + (non-essential t)) + (set-auto-mode) + (font-lock-mode 1))) + (message "preview buffer: mode=%s claims=%s cache=%S" + major-mode (file-name-nondirectory (or buffer-file-name "none")) + (repro--build-cache (current-buffer)))) + + (message "-- both buffers live: real=%S claiming-file=%d --" + (with-current-buffer real (avl-tree-size org-element--cache)) + (length (seq-filter (lambda (b) (equal (buffer-local-value 'buffer-file-name b) file)) + (buffer-list)))) + + ;; --- dirvish kills the preview buffer when the session ends --- + (let ((kill-buffer-query-functions nil) + (preview (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (kill-buffer preview) + (message "preview buffer %S killed" preview)) + + ;; --- is the real buffer still coherent? --- + (with-current-buffer real + ;; Edit it the way Craig would after stepping back from dirvish. + (goto-char (point-max)) + (condition-case err + (let ((inhibit-read-only t)) (insert "\n* Repro edit\n")) + (error (message "RESULT: insert into real buffer SIGNALLED %S" (car err)))) + (condition-case err + (progn (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (message "post-kill cache-map: clean (size=%S)" + (avl-tree-size org-element--cache))) + (error (message "post-kill cache-map: ERROR %S" err))) + (set-buffer-modified-p nil)) + + (message "warnings=%s" (or (repro--warnings) "none"))) + + (delete-file file)) diff --git a/working/org-element-cache-persist-bug/verify-shipped-fix.el b/working/org-element-cache-persist-bug/verify-shipped-fix.el new file mode 100644 index 00000000..a8883085 --- /dev/null +++ b/working/org-element-cache-persist-bug/verify-shipped-fix.el @@ -0,0 +1,91 @@ +;;; repro-preview-cache.el --- Does dirvish's text preview disturb an org buffer's element cache? -*- lexical-binding: t -*- + +;; Replays `dirvish--preview-file-maybe-truncate' (dirvish.el:653-684) against an +;; org file that is ALSO open for real, then kills the preview buffer the way +;; dirvish does (`dirvish--kill-buffer', dirvish.el:416). The kill is the step +;; that matters: killing an org-mode buffer with a `buffer-file-name' is when +;; org-persist writes that file's cache. + +(require 'org) +(require 'org-element) +(require 'org-persist) +(add-to-list 'load-path (expand-file-name "modules" default-directory)) +(require 'dirvish-config) + +(setq org-element-use-cache t + org-element-cache-persistent t + org-element--cache-self-verify t + org-element--cache-self-verify-frequency 1.0) + +(defun repro--build-cache (buf) + "Actually populate the element cache of BUF by walking it." + (with-current-buffer buf + (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (and org-element--cache (avl-tree-size org-element--cache)))) + +(defun repro--warnings () + (when (get-buffer "*Warnings*") + (with-current-buffer "*Warnings*" (string-trim (buffer-string))))) + +(let* ((src (expand-file-name "todo.org" default-directory)) + (file (make-temp-file "repro-" nil ".org")) + (threshold 1048576)) + (copy-file src file t) + (let ((size (nth 7 (file-attributes file)))) + (message "== fixture %s (%d bytes, %s threshold) ==" + (file-name-nondirectory file) size + (if (>= size threshold) "over" "under"))) + + (let ((real (find-file-noselect file))) + (message "real buffer cache after full walk: %S" (repro--build-cache real)) + + ;; --- dirvish text preview of the same file --- + (with-current-buffer (get-buffer-create "*preview-temp*") + (let (jka-compr-verbose) + (with-silent-modifications + (setq buffer-read-only t) + (insert-file-contents file nil 0 threshold) + (when (>= (nth 7 (file-attributes file)) threshold) + (goto-char (point-max)) + (insert "\n\nFile truncated. End of partial preview.\n")) + (setq buffer-file-name file) + (goto-char (point-min)) + (rename-buffer (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (let ((enable-dir-local-variables nil) + (enable-local-variables :safe) + (non-essential t)) + (set-auto-mode) + (font-lock-mode 1)) + (run-hooks 'dirvish-preview-setup-hook)) + (message "preview buffer: mode=%s claims=%s cache=%S" + major-mode (file-name-nondirectory (or buffer-file-name "none")) + (repro--build-cache (current-buffer)))) + + (message "-- both buffers live: real=%S claiming-file=%d --" + (with-current-buffer real (avl-tree-size org-element--cache)) + (length (seq-filter (lambda (b) (equal (buffer-local-value 'buffer-file-name b) file)) + (buffer-list)))) + + ;; --- dirvish kills the preview buffer when the session ends --- + (let ((kill-buffer-query-functions nil) + (preview (format "PREVIEW :: %s" (file-name-nondirectory file)))) + (kill-buffer preview) + (message "preview buffer %S killed" preview)) + + ;; --- is the real buffer still coherent? --- + (with-current-buffer real + ;; Edit it the way Craig would after stepping back from dirvish. + (goto-char (point-max)) + (condition-case err + (let ((inhibit-read-only t)) (insert "\n* Repro edit\n")) + (error (message "RESULT: insert into real buffer SIGNALLED %S" (car err)))) + (condition-case err + (progn (org-element-cache-map (lambda (_el) nil) :granularity 'element) + (message "post-kill cache-map: clean (size=%S)" + (avl-tree-size org-element--cache))) + (error (message "post-kill cache-map: ERROR %S" err))) + (set-buffer-modified-p nil)) + + (message "warnings=%s" (or (repro--warnings) "none"))) + + (delete-file file)) |