diff options
90 files changed, 7004 insertions, 225 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/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,6 +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 '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 @@ -159,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-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 77ff88a5..e9586a97 100644 --- a/modules/prog-general.el +++ b/modules/prog-general.el @@ -119,9 +119,11 @@ 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. 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 5a20d430..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 @@ -68,20 +69,29 @@ ;; 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.64" and max is nil, so that test never passes and the image is always +;; "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. ;; -;; Pinning by digest names one immutable image. Set to nil to hand the choice -;; back to telega. +;; 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 - "zevlg/telega-server@sha256:a4b88e029ba381eca7c37c9618c9e3ad73aa9db2097fe07a0c6684d40d32b84e" + "cj/telega-server:1.8.66-glycin" "Container image reference for `telega-server', or nil for telega's default. -Pin by digest rather than tag: a tag can be re-pushed upstream, a digest -cannot. The default is the image carrying libtdjson 1.8.64, which matches -this telega's `telega-tdlib-min-version'." +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) @@ -175,6 +185,21 @@ into telega's sentinel and abort its status handling and relogin path." (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. @@ -183,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-bootstrap-packages.bats b/tests/test-bootstrap-packages.bats new file mode 100644 index 00000000..7e511152 --- /dev/null +++ b/tests/test-bootstrap-packages.bats @@ -0,0 +1,142 @@ +#!/usr/bin/env bats +# Tests for scripts/bootstrap-packages.sh — the headless package installer. +# +# The elisp tests cover what happens inside one Emacs. What only a shell test +# can cover is the pass loop: whether a run that reports packages still missing +# gets another pass, whether a run that converges stops early, and whether a +# broken init breaks out instead of burning every pass on the same failure. +# +# Every test drives a fake emacs whose exit statuses are scripted, so no test +# touches the network, the real elpa directory, or a real Emacs. The script +# honours $EMACS, which is the seam these hang on. + +setup() { + SCRIPT="${BATS_TEST_DIRNAME}/../scripts/bootstrap-packages.sh" + BIN="${BATS_TEST_TMPDIR}/bin" + COUNTER="${BATS_TEST_TMPDIR}/attempts" + mkdir -p "$BIN" + echo 0 >"$COUNTER" + export BOOTSTRAP_PASSES=3 + export BOOTSTRAP_TIMEOUT=30 + # Point the script at a scratch config dir rather than the real checkout, so + # the byte-compiled-modules check reads fixture state instead of whatever + # this working tree happens to have compiled. + export BOOTSTRAP_DIR="${BATS_TEST_TMPDIR}/emacsd" + mkdir -p "$BOOTSTRAP_DIR/modules" +} + +# Write a fake emacs that exits with the given statuses in order, repeating the +# last one once the list runs out. Status 1 also prints the "still missing" +# line the real cj/package-bootstrap-batch prints, so the script's grep is +# exercised rather than assumed. +fake_emacs() { + { + echo '#!/usr/bin/env bash' + echo "n=\$(cat '$COUNTER')" + echo "n=\$((n + 1))" + echo "echo \$n >'$COUNTER'" + echo "statuses=($*)" + echo 'idx=$((n - 1))' + echo 'last=$((${#statuses[@]} - 1))' + echo '[ $idx -gt $last ] && idx=$last' + echo 'status=${statuses[$idx]}' + echo '[ "$status" -eq 1 ] && echo "package-bootstrap: 2 missing: foo bar"' + echo 'exit $status' + } >"$BIN/emacs" + chmod +x "$BIN/emacs" + export EMACS="$BIN/emacs" +} + +attempts() { cat "$COUNTER"; } + +@test "normal: a clean first pass succeeds and stops there" { + fake_emacs 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 1 ] + [[ "$output" == *"every package is installed"* ]] +} + +@test "normal: a pass reporting missing packages is retried until it converges" { + fake_emacs 1 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 2 ] + [[ "$output" == *"2 missing: foo bar"* ]] +} + +@test "error: packages that never install exhaust the passes and fail" { + fake_emacs 1 + run bash "$SCRIPT" + [ "$status" -eq 1 ] + [ "$(attempts)" -eq 3 ] + [[ "$output" == *"FAILED"* ]] +} + +@test "error: exit 1 without a missing-packages line is not blamed on packages" { + # The fake exits 1 silently, which is any other failure, not a short install. + { + echo '#!/usr/bin/env bash' + echo "n=\$(cat '$COUNTER'); echo \$((n + 1)) >'$COUNTER'" + echo 'exit 1' + } >"$BIN/emacs" + chmod +x "$BIN/emacs" + export EMACS="$BIN/emacs" + run bash "$SCRIPT" + [ "$status" -eq 1 ] + [ "$(attempts)" -eq 1 ] + [[ "$output" == *"without reporting missing packages"* ]] +} + +@test "error: a broken init breaks out instead of burning every pass" { + fake_emacs 255 + run bash "$SCRIPT" + [ "$status" -eq 255 ] + [ "$(attempts)" -eq 1 ] + [[ "$output" == *"failed to load init"* ]] +} + +@test "boundary: a timed-out pass is reported and still retried" { + fake_emacs 124 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 2 ] + [[ "$output" == *"timeout"* ]] +} + +@test "boundary: the pass ceiling is honoured" { + export BOOTSTRAP_PASSES=1 + fake_emacs 1 + run bash "$SCRIPT" + [ "$status" -eq 1 ] + [ "$(attempts)" -eq 1 ] +} + +@test "error: a byte-compiled tree is refused rather than passed vacuously" { + touch "$BOOTSTRAP_DIR/modules/foo.elc" + fake_emacs 0 + run bash "$SCRIPT" + [ "$status" -eq 2 ] + [ "$(attempts)" -eq 0 ] + [[ "$output" == *"REFUSING"* ]] + [[ "$output" == *"clean-compiled"* ]] + [[ "$output" != *"every package is installed"* ]] +} + +@test "boundary: a zero pass ceiling fails cleanly without a tail error" { + export BOOTSTRAP_PASSES=0 + fake_emacs 0 + run bash "$SCRIPT" + [ "$status" -ne 0 ] + [ "$(attempts)" -eq 0 ] + [[ "$output" != *"cannot open"* ]] + [[ "$output" == *"FAILED after 0 pass"* ]] +} + +@test "boundary: recovery on the final allowed pass still succeeds" { + export BOOTSTRAP_PASSES=3 + fake_emacs 1 1 0 + run bash "$SCRIPT" + [ "$status" -eq 0 ] + [ "$(attempts)" -eq 3 ] +} diff --git a/tests/test-calendar-sync--batch-failures.el b/tests/test-calendar-sync--batch-failures.el new file mode 100644 index 00000000..3190be21 --- /dev/null +++ b/tests/test-calendar-sync--batch-failures.el @@ -0,0 +1,47 @@ +;;; test-calendar-sync--batch-failures.el --- Batch failure filter tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; `calendar-sync--batch-failures' picks the rows that did not finish cleanly. +;; The batch runner's exit code is derived from it, and systemd reads that exit +;; code, so the rule is deliberately strict: only `ok' passes. A calendar left +;; `syncing' at the timeout, or one that never started, is a failure -- both +;; states mean the org file on disk is not the calendar's current contents, +;; which is exactly the silent staleness the timer exists to prevent. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(ert-deftest test-calendar-sync-batch-failures-keeps-only-non-ok () + "Normal: an errored calendar is returned and a healthy one is not." + (should (equal (calendar-sync--batch-failures + '(("google" . ok) ("proton" . error))) + '(("proton" . error))))) + +(ert-deftest test-calendar-sync-batch-failures-all-ok-is-empty () + "Normal: a fully successful run reports no failures." + (should (equal (calendar-sync--batch-failures + '(("google" . ok) ("proton" . ok))) + '()))) + +(ert-deftest test-calendar-sync-batch-failures-empty-input-is-empty () + "Boundary: no rows in, no rows out." + (should (equal (calendar-sync--batch-failures '()) '()))) + +(ert-deftest test-calendar-sync-batch-failures-timeout-counts-as-failure () + "Error: a calendar still `syncing' when the wait expired is a failure. +Its org file was not rewritten, so reporting success would hide the staleness." + (should (equal (calendar-sync--batch-failures + '(("google" . ok) ("proton" . syncing))) + '(("proton" . syncing))))) + +(ert-deftest test-calendar-sync-batch-failures-never-counts-as-failure () + "Error: a calendar that never started is a failure, not a skip." + (should (equal (calendar-sync--batch-failures '(("google" . never))) + '(("google" . never))))) + +(provide 'test-calendar-sync--batch-failures) +;;; test-calendar-sync--batch-failures.el ends here diff --git a/tests/test-calendar-sync--batch-report.el b/tests/test-calendar-sync--batch-report.el new file mode 100644 index 00000000..12811200 --- /dev/null +++ b/tests/test-calendar-sync--batch-report.el @@ -0,0 +1,89 @@ +;;; test-calendar-sync--batch-report.el --- Batch report output tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; `calendar-sync-batch-run-and-report' is what the systemd timer runs, so its +;; printed rows are the only record that survives the process. Batch Emacs +;; discards *Messages* at exit, which is where the interactive failure path +;; logs its reason -- so a failed row has to carry its recorded `:last-error' +;; in the printed output or the journal shows "error" with no way to tell a +;; cold gpg-agent from a revoked feed token or a dead network. + +;;; Code: + +(require 'ert) +(require 'cl-lib) ;; cl-letf; calendar-sync pulls it in transitively, don't rely on that + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(defun test-calendar-sync-batch-report--capture (states results) + "Return the report's printed output for STATES and RESULTS. +STATES is an alist of NAME . PLIST seeded into the state table; RESULTS is +what `calendar-sync-batch-run' is stubbed to return, so the report is +exercised without driving a real sync." + (let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + (dolist (entry states) + (puthash (car entry) (cdr entry) calendar-sync--calendar-states)) + (cl-letf (((symbol-function 'calendar-sync-batch-run) + (lambda (&rest _) results))) + (with-output-to-string + (calendar-sync-batch-run-and-report))))) + +;;; Normal + +(ert-deftest test-calendar-sync-batch-report-failed-row-carries-its-reason () + "Normal: a failed calendar prints the recorded `:last-error' reason. +Without it the journal records only \"error\", and the operator cannot tell a +cold gpg-agent from a revoked token without re-running the sync by hand." + (let ((out (test-calendar-sync-batch-report--capture + '(("google" . (:status error :last-error "Decryption failed")) + ("proton" . (:status ok))) + '(("google" . error) ("proton" . ok))))) + (should (string-match-p "google: error" out)) + (should (string-match-p "Decryption failed" out)))) + +(ert-deftest test-calendar-sync-batch-report-ok-row-stays-bare () + "Normal: a calendar that synced prints its status and nothing more. +A stale `:last-error' from an earlier failure must not be appended to a row +that succeeded this run." + (let ((out (test-calendar-sync-batch-report--capture + '(("google" . (:status ok :last-error "Decryption failed"))) + '(("google" . ok))))) + (should (string-match-p "google: ok" out)) + (should-not (string-match-p "Decryption failed" out)))) + +;;; Boundary + +(ert-deftest test-calendar-sync-batch-report-failure-without-reason-still-prints () + "Boundary: a failed row with no recorded reason prints its status alone. +`never' and `syncing' never record a `:last-error', so the reason lookup has +to tolerate nil rather than printing \"nil\" or signalling." + (let ((out (test-calendar-sync-batch-report--capture + '(("google" . (:status syncing))) + '(("google" . syncing) ("absent" . never))))) + (should (string-match-p "google: syncing" out)) + (should (string-match-p "absent: never" out)) + (should-not (string-match-p "nil" out)))) + +;;; Error + +(defun test-calendar-sync-batch-report--exit-code (results) + "Return the report's exit code for RESULTS, discarding its printed output." + (let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + (cl-letf (((symbol-function 'calendar-sync-batch-run) + (lambda (&rest _) results))) + (with-temp-buffer + (let ((standard-output (current-buffer))) + (calendar-sync-batch-run-and-report)))))) + +(ert-deftest test-calendar-sync-batch-report-exit-code-tracks-failures () + "Error: the return value becomes the process exit code, so it stays 1 on any +non-ok row and 0 only when every calendar synced. Appending the reason to the +printed line must not disturb it." + (should (equal 1 (test-calendar-sync-batch-report--exit-code '(("google" . error))))) + (should (equal 1 (test-calendar-sync-batch-report--exit-code + '(("google" . ok) ("proton" . never))))) + (should (equal 0 (test-calendar-sync-batch-report--exit-code '(("google" . ok)))))) + +(provide 'test-calendar-sync--batch-report) +;;; test-calendar-sync--batch-report.el ends here diff --git a/tests/test-calendar-sync--batch-results.el b/tests/test-calendar-sync--batch-results.el new file mode 100644 index 00000000..03ee2aee --- /dev/null +++ b/tests/test-calendar-sync--batch-results.el @@ -0,0 +1,59 @@ +;;; test-calendar-sync--batch-results.el --- Batch result collection tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; `calendar-sync--batch-results' reads the per-calendar state table and +;; returns one (NAME . STATUS) pair per requested calendar. The batch runner +;; turns that into an exit code, so a calendar that never reached the table at +;; all has to read as `never' rather than nil -- a nil status would compare +;; equal to nothing and quietly drop out of the failure count. + +;;; Code: + +(require 'ert) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(defun test-calendar-sync-batch-results--with-states (states body) + "Run BODY with STATES (an alist of NAME . PLIST) in the state table." + (let ((calendar-sync--calendar-states (make-hash-table :test 'equal))) + (dolist (entry states) + (puthash (car entry) (cdr entry) calendar-sync--calendar-states)) + (funcall body))) + +(ert-deftest test-calendar-sync-batch-results-reports-each-status () + "Normal: every requested calendar comes back with its recorded status." + (test-calendar-sync-batch-results--with-states + '(("google" . (:status ok)) + ("proton" . (:status error :last-error "boom"))) + (lambda () + (should (equal (calendar-sync--batch-results '("google" "proton")) + '(("google" . ok) ("proton" . error))))))) + +(ert-deftest test-calendar-sync-batch-results-empty-names-is-empty () + "Boundary: no calendars requested yields no rows, not an error." + (test-calendar-sync-batch-results--with-states + '(("google" . (:status ok))) + (lambda () + (should (equal (calendar-sync--batch-results '()) '()))))) + +(ert-deftest test-calendar-sync-batch-results-missing-calendar-reads-never () + "Error: a calendar absent from the state table reads `never', never nil. +A nil status would drop out of the failure count and report success for a +calendar that never ran." + (test-calendar-sync-batch-results--with-states + '(("google" . (:status ok))) + (lambda () + (should (equal (calendar-sync--batch-results '("google" "absent")) + '(("google" . ok) ("absent" . never))))))) + +(ert-deftest test-calendar-sync-batch-results-preserves-request-order () + "Boundary: rows come back in the order asked for, not hash order." + (test-calendar-sync-batch-results--with-states + '(("a" . (:status ok)) ("b" . (:status ok)) ("c" . (:status ok))) + (lambda () + (should (equal (mapcar #'car (calendar-sync--batch-results '("c" "a" "b"))) + '("c" "a" "b")))))) + +(provide 'test-calendar-sync--batch-results) +;;; test-calendar-sync--batch-results.el ends here diff --git a/tests/test-calendar-sync--batch-wait.el b/tests/test-calendar-sync--batch-wait.el new file mode 100644 index 00000000..7deee5e1 --- /dev/null +++ b/tests/test-calendar-sync--batch-wait.el @@ -0,0 +1,68 @@ +;;; test-calendar-sync--batch-wait.el --- Batch wait-loop tests -*- lexical-binding: t; -*- + +;;; Commentary: +;; The sync pipeline is asynchronous end to end: curl runs in one process and +;; the org conversion in a second batch Emacs. Under `emacs --batch' the +;; process exits as soon as the top-level form returns, killing both children +;; mid-flight -- a run that does nothing and reports success. +;; +;; `calendar-sync--batch-wait' is what stops that: it blocks until every +;; calendar has left the `syncing' state, or until the timeout expires. These +;; tests drive it with a stubbed state predicate, so the loop's exit conditions +;; are covered without a live network fetch. + +;;; Code: + +(require 'ert) +(require 'cl-lib) + +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'calendar-sync) + +(ert-deftest test-calendar-sync-batch-wait-returns-when-nothing-in-flight () + "Normal: with no calendar syncing the wait returns success immediately." + (let ((polls 0)) + (cl-letf (((symbol-function 'calendar-sync--syncing-p) (lambda (_) nil)) + ((symbol-function 'accept-process-output) + (lambda (&rest _) (setq polls (1+ polls))))) + (should (calendar-sync--batch-wait '("google" "proton") 5)) + (should (= polls 0))))) + +(ert-deftest test-calendar-sync-batch-wait-blocks-until-settled () + "Normal: the wait polls while a sync is in flight and returns once it lands." + (let ((remaining 3) + (polls 0)) + (cl-letf (((symbol-function 'calendar-sync--syncing-p) + (lambda (_) (> remaining 0))) + ((symbol-function 'accept-process-output) + (lambda (&rest _) + (setq polls (1+ polls)) + (setq remaining (1- remaining))))) + (should (calendar-sync--batch-wait '("google") 5)) + (should (= polls 3))))) + +(ert-deftest test-calendar-sync-batch-wait-empty-names-returns-immediately () + "Boundary: no calendars to wait on settles at once." + (let ((polls 0)) + (cl-letf (((symbol-function 'accept-process-output) + (lambda (&rest _) (setq polls (1+ polls))))) + (should (calendar-sync--batch-wait '() 5)) + (should (= polls 0))))) + +(ert-deftest test-calendar-sync-batch-wait-times-out-when-stuck () + "Error: a sync that never settles returns nil once the timeout expires. +Returning nil is what lets the runner exit non-zero instead of reporting a +success it cannot vouch for." + (let ((calendar-sync--batch-poll-seconds 0.01)) + (cl-letf (((symbol-function 'calendar-sync--syncing-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) (lambda (&rest _) nil))) + (should-not (calendar-sync--batch-wait '("google") 0.05))))) + +(ert-deftest test-calendar-sync-batch-wait-zero-timeout-does-not-hang () + "Boundary: a zero timeout returns at once rather than looping forever." + (cl-letf (((symbol-function 'calendar-sync--syncing-p) (lambda (_) t)) + ((symbol-function 'accept-process-output) (lambda (&rest _) nil))) + (should-not (calendar-sync--batch-wait '("google") 0)))) + +(provide 'test-calendar-sync--batch-wait) +;;; test-calendar-sync--batch-wait.el ends here diff --git a/tests/test-calendar-sync--sync-dispatch.el b/tests/test-calendar-sync--sync-dispatch.el index 22deeef0..9b12b167 100644 --- a/tests/test-calendar-sync--sync-dispatch.el +++ b/tests/test-calendar-sync--sync-dispatch.el @@ -77,5 +77,44 @@ than crashing." (should (equal (list cal) ics-calls)) (should (null api-calls))))) +(ert-deftest test-calendar-sync--sync-dispatch-error-leaf-signal-is-contained () + "Error: a syncer that signals marks the calendar failed instead of propagating. + +Resolving a `:secret-host' feed reads authinfo.gpg, and a cold gpg-agent makes +that signal a `file-error' before any process starts — so the failure arrives +synchronously, where the async callbacks that normally record a failure never +run." + (let ((failed '()) + (calendar-sync--calendar-states (make-hash-table :test 'equal))) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (_) (signal 'file-error '("Decryption failed")))) + ((symbol-function 'calendar-sync--mark-sync-failed) + (lambda (name reason) (push (cons name reason) failed)))) + (calendar-sync--sync-calendar + '(:name "google" :url "https://x/y.ics" :file "/tmp/c.org")) + (should (equal "google" (car (car failed))))))) + +(ert-deftest test-calendar-sync--sync-all-continues-past-a-failing-calendar () + "Error: one calendar's synchronous failure does not stop the ones after it. + +This is the whole cost of leaving the signal uncontained: on a machine whose +feeds resolve through authinfo, the first calendar's decryption error aborted +the entire run, so calendars that would have synced fine never got the chance." + (let ((synced '()) + (calendar-sync--calendar-states (make-hash-table :test 'equal)) + (calendar-sync-calendars + '((:name "bad" :url "https://x/a.ics" :file "/tmp/a.org") + (:name "good" :url "https://x/b.ics" :file "/tmp/b.org")))) + (cl-letf (((symbol-function 'calendar-sync--sync-calendar-ics) + (lambda (cal) + (if (equal (plist-get cal :name) "bad") + (signal 'file-error '("Decryption failed")) + (push (plist-get cal :name) synced)))) + ((symbol-function 'calendar-sync--mark-sync-failed) + (lambda (&rest _) nil)) + ((symbol-function 'message) (lambda (&rest _) nil))) + (calendar-sync--sync-all-calendars) + (should (equal '("good") synced))))) + (provide 'test-calendar-sync--sync-dispatch) ;;; test-calendar-sync--sync-dispatch.el ends here diff --git a/tests/test-calendar-sync-run.bats b/tests/test-calendar-sync-run.bats new file mode 100644 index 00000000..da817060 --- /dev/null +++ b/tests/test-calendar-sync-run.bats @@ -0,0 +1,116 @@ +#!/usr/bin/env bats +# Tests for scripts/calendar-sync-run — the batch syncer behind the timer. +# +# The elisp tests cover the wait loop and the result tally with the state +# predicate stubbed. What only a shell test can cover is the thing that makes +# the whole script necessary: the sync pipeline is asynchronous end to end +# (curl in one process, the org conversion in a second batch Emacs), and a +# batch Emacs exits as soon as its top-level form returns. A version that +# launches the fetch and returns would exit zero, write nothing, and look +# exactly like a success. Every assertion here that checks the output file +# exists is really asserting that the script waited. +# +# Isolation rules, mirroring test-agenda-render-cache.bats: +# +# EMACS_D points at THIS checkout, so a broken tree cannot pass by running +# the installed config's elisp. +# +# CALENDAR_SYNC_CONFIG and CALENDAR_SYNC_STATE point at fixtures, so the run +# neither reads Craig's real feed URLs nor writes his persisted sync state. +# +# The feed is a file:// URL served to the script's own curl. That keeps the +# test hermetic -- no network, no live calendar -- while still exercising the +# real fetch path rather than a stub. + +setup() { + SCRIPT="${BATS_TEST_DIRNAME}/../scripts/calendar-sync-run" + export EMACS_D="${BATS_TEST_DIRNAME}/.." + export CALENDAR_SYNC_STATE="${BATS_TEST_TMPDIR}/state.el" + export CALENDAR_SYNC_TIMEOUT=120 + + OUT="${BATS_TEST_TMPDIR}/testcal.org" + ICS="${BATS_TEST_TMPDIR}/feed.ics" + TODAY="$(date +%Y%m%d)" + + cat > "$ICS" <<-EOF + BEGIN:VCALENDAR + VERSION:2.0 + PRODID:-//bats//test//EN + BEGIN:VEVENT + UID:bats-fixture-1 + DTSTART:${TODAY}T140000Z + DTEND:${TODAY}T150000Z + SUMMARY:Batch Fixture Event + END:VEVENT + END:VCALENDAR + EOF + + write_config "file://${ICS}" +} + +# The calendar list is normally private config; the test writes its own so the +# feed URL is a local file and the output lands in the temp dir. +write_config() { + export CALENDAR_SYNC_CONFIG="${BATS_TEST_TMPDIR}/config.el" + cat > "$CALENDAR_SYNC_CONFIG" <<-EOF + (setq calendar-sync-calendars + (list (list :name "testcal" :url "$1" :file "${OUT}"))) + EOF +} + +@test "the script is executable" { + [ -x "$SCRIPT" ] +} + +@test "waits for the async pipeline and writes the org file" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # The file existing at all is the assertion: it is written by a grandchild + # process, so a script that did not wait would have exited before this. + [ -f "$OUT" ] + grep -q "Batch Fixture Event" "$OUT" +} + +@test "reports the calendar and its status on stdout" { + run "$SCRIPT" + [ "$status" -eq 0 ] + [[ "$output" == *"testcal: ok"* ]] +} + +@test "a failed fetch exits non-zero so systemd records it" { + write_config "file://${BATS_TEST_TMPDIR}/does-not-exist.ics" + run "$SCRIPT" + [ "$status" -ne 0 ] + [ ! -f "$OUT" ] +} + +@test "a failed fetch names the calendar rather than failing silently" { + write_config "file://${BATS_TEST_TMPDIR}/does-not-exist.ics" + run "$SCRIPT" + [[ "$output" == *"testcal"* ]] + [[ "$output" != *"testcal: ok"* ]] +} + +@test "a failed fetch prints why, not just that it failed" { + # The interactive path logs the reason to *Messages*, which batch Emacs + # discards at exit. Without the reason on stdout the journal shows only + # "error" -- no way to tell a cold gpg-agent from a revoked feed token. + write_config "file://${BATS_TEST_TMPDIR}/does-not-exist.ics" + run "$SCRIPT" + [[ "$output" == *"testcal: error"* ]] + [[ "$output" == *"Fetch failed"* ]] +} + +@test "refuses to run against a checkout with no modules directory" { + EMACS_D="${BATS_TEST_TMPDIR}/empty" run "$SCRIPT" + [ "$status" -ne 0 ] + [[ "$output" == *"no modules directory"* ]] +} + +@test "does not write the real session's sync state" { + run "$SCRIPT" + [ "$status" -eq 0 ] + # The state override is honoured, so a timer run cannot corrupt or race + # the interactive session's persisted state. + [ -f "$CALENDAR_SYNC_STATE" ] +} diff --git a/tests/test-calibredb-epub-config.el b/tests/test-calibredb-epub-config.el index 7afc58f3..0e430a4e 100644 --- a/tests/test-calibredb-epub-config.el +++ b/tests/test-calibredb-epub-config.el @@ -16,6 +16,11 @@ (package-initialize) (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'calibredb-epub-config) +;; Load calibredb before any test stubs its functions with `cl-letf'. The +;; module's jump path calls `(require 'calibredb)' inside the body; if the +;; package is still an autoload at that point, the real `defun' lands on top of +;; the stub and the test runs the real command against the real library. +(require 'calibredb) (require 'nov nil t) ; for the nov-mode-map keybinding test; harmless if absent (declare-function cj/nov--text-width "calibredb-epub-config" (total-cols)) diff --git a/tests/test-config-utilities--compile-this-elisp-buffer.el b/tests/test-config-utilities--compile-this-elisp-buffer.el index a06440ab..f1a442b4 100644 --- a/tests/test-config-utilities--compile-this-elisp-buffer.el +++ b/tests/test-config-utilities--compile-this-elisp-buffer.el @@ -1,10 +1,14 @@ ;;; test-config-utilities--compile-this-elisp-buffer.el --- Tests for cj/compile-this-elisp-buffer -*- lexical-binding: t; -*- ;;; Commentary: -;; Tests for `cj/compile-this-elisp-buffer'. The function dispatches -;; among native-compile-async, native-compile (sync), and -;; byte-compile-file based on which is fboundp. Tests force each -;; branch by mocking fboundp at the boundary. +;; Tests for `cj/compile-this-elisp-buffer' and its helper +;; `cj/--compile-elisp-file'. The helper dispatches among +;; native-compile-async, native-compile (sync), and byte-compile-file based +;; on an AVAILABLE-P predicate that defaults to `fboundp'. Tests force each +;; branch by passing the predicate, never by redefining `fboundp': an `fset' +;; on that subr autoloads comp-run, which requires bytecomp, whose `defun' of +;; `byte-compile-file' replaces any test double installed earlier in the same +;; `cl-letf' (Emacs 30.2 hid this because ert happened to preload bytecomp). ;;; Code: @@ -14,6 +18,10 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'config-utilities) +(defun test-config-utilities--available (&rest syms) + "Return a predicate that reports only SYMS as available compilers." + (lambda (sym) (memq sym syms))) + (defmacro test-config-utilities--with-elisp-buffer (path &rest body) "Run BODY in a temp buffer visiting PATH (a .el file path). Skips the interactive `save-buffer' so tests stay free of disk side @@ -24,72 +32,108 @@ effects." (cl-letf (((symbol-function 'save-buffer) (lambda (&rest _) nil))) ,@body))) +;; -- the interactive wrapper ------------------------------------------------- + (ert-deftest test-config-utilities-compile-buffer-not-elisp-raises () "Error: a buffer whose file isn't .el raises `user-error'." (test-config-utilities--with-elisp-buffer "/tmp/not-elisp.txt" (should-error (cj/compile-this-elisp-buffer) :type 'user-error))) -(ert-deftest test-config-utilities-compile-buffer-no-buffer-file-name-raises () - "Error: a buffer with no `buffer-file-name' raises `user-error'." +(ert-deftest test-config-utilities-compile-buffer-no-file-raises () + "Boundary: a buffer visiting no file raises `user-error' rather than +passing nil to the compiler." (with-temp-buffer - (setq buffer-file-name nil) (should-error (cj/compile-this-elisp-buffer) :type 'user-error))) +(ert-deftest test-config-utilities-compile-buffer-saves-then-delegates () + "Normal: the wrapper saves the buffer and hands its file to the helper." + (let (saved compiled) + (with-temp-buffer + (setq buffer-file-name "/tmp/some.el") + (cl-letf (((symbol-function 'save-buffer) (lambda (&rest _) (setq saved t))) + ((symbol-function 'cj/--compile-elisp-file) + (lambda (file &optional _) (setq compiled file)))) + (cj/compile-this-elisp-buffer))) + (should saved) + (should (equal compiled "/tmp/some.el")))) + +;; -- the helper's dispatch --------------------------------------------------- + (ert-deftest test-config-utilities-compile-buffer-prefers-native-async () "Normal: `native-compile-async' is preferred when available." (let (called-with) - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) - (memq sym '(native-compile-async native-compile byte-compile-file)))) - ((symbol-function 'native-compile-async) - (lambda (file) (setq called-with file))) - ((symbol-function 'native-compile) - (lambda (_) (error "should not call sync native-compile"))) - ((symbol-function 'byte-compile-file) - (lambda (&rest _) (error "should not call byte-compile-file")))) - (cj/compile-this-elisp-buffer) - (should (equal called-with "/tmp/some.el")))))) + (cl-letf (((symbol-function 'native-compile-async) + (lambda (file) (setq called-with file))) + ((symbol-function 'native-compile) + (lambda (_) (error "should not call sync native-compile"))) + ((symbol-function 'byte-compile-file) + (lambda (&rest _) (error "should not call byte-compile-file")))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'native-compile-async 'native-compile + 'byte-compile-file)) + (should (equal called-with "/tmp/some.el"))))) (ert-deftest test-config-utilities-compile-buffer-falls-back-to-sync-native () "Normal: `native-compile' is used when async isn't available." (let (called-with) - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) (memq sym '(native-compile byte-compile-file)))) - ((symbol-function 'native-compile) - (lambda (file) (setq called-with file))) - ((symbol-function 'byte-compile-file) - (lambda (&rest _) (error "should not call byte-compile-file")))) - (cj/compile-this-elisp-buffer) - (should (equal called-with "/tmp/some.el")))))) + (cl-letf (((symbol-function 'native-compile) + (lambda (file) (setq called-with file))) + ((symbol-function 'byte-compile-file) + (lambda (&rest _) (error "should not call byte-compile-file")))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'native-compile 'byte-compile-file)) + (should (equal called-with "/tmp/some.el"))))) (ert-deftest test-config-utilities-compile-buffer-falls-back-to-byte-compile () "Normal: `byte-compile-file' is used when neither native option is available." (let (called-with) - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) (eq sym 'byte-compile-file))) - ((symbol-function 'byte-compile-file) - (lambda (file &rest _) (setq called-with file) "/tmp/some.elc"))) - (cj/compile-this-elisp-buffer) - (should (equal called-with "/tmp/some.el")))))) + (cl-letf (((symbol-function 'byte-compile-file) + (lambda (file &rest _) (setq called-with file) "/tmp/some.elc"))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'byte-compile-file)) + (should (equal called-with "/tmp/some.el"))))) + +(ert-deftest test-config-utilities-compile-buffer-reports-when-nothing-available () + "Boundary: with no compiler available the helper only messages, calling none." + (let (captured) + (cl-letf (((symbol-function 'native-compile-async) + (lambda (&rest _) (error "should not call native-compile-async"))) + ((symbol-function 'native-compile) + (lambda (&rest _) (error "should not call native-compile"))) + ((symbol-function 'byte-compile-file) + (lambda (&rest _) (error "should not call byte-compile-file"))) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--compile-elisp-file "/tmp/some.el" (test-config-utilities--available))) + (should (string-match-p "No compilation available" captured)))) (ert-deftest test-config-utilities-compile-buffer-handles-sync-native-error () "Error: a sync `native-compile' that signals is caught and reported. -Asserts no error escapes by running the function and checking that the +Asserts no error escapes by running the helper and checking that the message captured contains the failure prefix." - (test-config-utilities--with-elisp-buffer "/tmp/some.el" - (let (captured) - (cl-letf (((symbol-function 'fboundp) - (lambda (sym) (memq sym '(native-compile byte-compile-file)))) - ((symbol-function 'native-compile) - (lambda (_) (error "boom"))) - ((symbol-function 'message) - (lambda (fmt &rest args) - (setq captured (apply #'format fmt args))))) - (cj/compile-this-elisp-buffer)) - (should (string-match-p "Native compile failed" captured))))) + (let (captured) + (cl-letf (((symbol-function 'native-compile) + (lambda (_) (error "boom"))) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--compile-elisp-file + "/tmp/some.el" + (test-config-utilities--available 'native-compile 'byte-compile-file))) + (should (string-match-p "Native compile failed" captured)))) + +(ert-deftest test-config-utilities-compile-buffer-default-predicate-is-fboundp () + "Normal: with no predicate the helper consults `fboundp', so on a real +Emacs it reaches whichever compiler exists rather than the no-compiler +message." + (let (captured) + (cl-letf (((symbol-function 'native-compile-async) (lambda (&rest _) nil)) + ((symbol-function 'message) + (lambda (fmt &rest args) (setq captured (apply #'format fmt args))))) + (cj/--compile-elisp-file "/tmp/some.el")) + (should (string-match-p "Queued native compilation" captured)))) (provide 'test-config-utilities--compile-this-elisp-buffer) ;;; test-config-utilities--compile-this-elisp-buffer.el ends here diff --git a/tests/test-custom-buffer-file-move-buffer-and-file.el b/tests/test-custom-buffer-file-move-buffer-and-file.el index 8331db5c..b3d78ccf 100644 --- a/tests/test-custom-buffer-file-move-buffer-and-file.el +++ b/tests/test-custom-buffer-file-move-buffer-and-file.el @@ -884,11 +884,17 @@ (with-temp-file source-file (insert "new")) (find-file source-file) - ;; Mock yes-or-no-p to capture that it was called - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (prompt) + ;; The overwrite confirm goes through `cj/confirm-destructive', which + ;; reads a single key rather than a typed yes. Mock the key read, not + ;; `yes-or-no-p' -- mocking the latter would pass whether or not the + ;; prompt happened at all. + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (setq prompted t) - t)) + ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) + (error "overwrite confirm must not demand a typed yes"))) ((symbol-function 'read-directory-name) (lambda (&rest _) target-dir))) (call-interactively #'cj/move-buffer-and-file) @@ -907,11 +913,14 @@ (with-temp-file source-file (insert "new")) (find-file source-file) - ;; Mock yes-or-no-p to capture if it was called - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (prompt) - (setq prompted t) - t)) + ;; Both prompt paths are mocked, not just the old one. Watching + ;; `yes-or-no-p' alone would make this assertion unfalsifiable now + ;; that the confirm reads a key instead: it would pass whether the + ;; prompt was correctly skipped or merely moved. + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (setq prompted t) ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (setq prompted t) t)) ((symbol-function 'read-directory-name) (lambda (&rest _) target-dir))) (call-interactively #'cj/move-buffer-and-file) diff --git a/tests/test-custom-buffer-file-rename-buffer-and-file.el b/tests/test-custom-buffer-file-rename-buffer-and-file.el index 1eb61f1b..019fad8c 100644 --- a/tests/test-custom-buffer-file-rename-buffer-and-file.el +++ b/tests/test-custom-buffer-file-rename-buffer-and-file.el @@ -923,11 +923,17 @@ (with-temp-file new-file (insert "existing")) (find-file old-file) - ;; Mock yes-or-no-p to capture that it was called - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (prompt) + ;; The overwrite confirm goes through `cj/confirm-destructive', which + ;; reads a single key rather than a typed yes. Mock the key read, not + ;; `yes-or-no-p' -- mocking the latter would pass whether or not the + ;; prompt happened at all. + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (setq prompted t) - t)) + ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) + (error "overwrite confirm must not demand a typed yes"))) ((symbol-function 'read-string) (lambda (&rest _) "new.txt"))) (call-interactively #'cj/rename-buffer-and-file) diff --git a/tests/test-google-keep-config--local-config.el b/tests/test-google-keep-config--local-config.el new file mode 100644 index 00000000..18769c5a --- /dev/null +++ b/tests/test-google-keep-config--local-config.el @@ -0,0 +1,52 @@ +;;; test-google-keep-config--local-config.el --- Tests for the Keep machine-local config loader -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for cj/keep--load-local-config, the loader for the gitignored +;; machine-local google-keep.local.el (venv interpreter path, account email) — +;; the same shape calendar-sync uses for calendar-sync.local.el. + +;;; Code: + +(require 'ert) +(require 'google-keep-config) + +(ert-deftest test-google-keep-local-config-loads-readable-file () + "Normal: a readable local config file is loaded and its settings apply." + (let ((file (make-temp-file "keep-local-" nil ".el"))) + (unwind-protect + (progn + (with-temp-file file + (insert "(setq test-google-keep--local-marker 'loaded)")) + (defvar test-google-keep--local-marker nil) + (setq test-google-keep--local-marker nil) + (let ((cj/keep-local-config-file file)) + (should (cj/keep--load-local-config)) + (should (eq test-google-keep--local-marker 'loaded)))) + (delete-file file)))) + +(ert-deftest test-google-keep-local-config-missing-file-is-quiet () + "Boundary: an absent local config file is a silent no-op, no error." + (let ((cj/keep-local-config-file "/nonexistent/google-keep.local.el")) + (should-not (cj/keep--load-local-config)))) + +(ert-deftest test-google-keep-local-config-broken-file-does-not-signal () + "Error: a local config file with a broken form is caught and reported, +never propagated as a load-time error." + (let ((file (make-temp-file "keep-local-broken-" nil ".el")) + (messages nil)) + (unwind-protect + (progn + (with-temp-file file + (insert "(error \"deliberately broken local config\")")) + (let ((cj/keep-local-config-file file)) + (cl-letf (((symbol-function 'message) + (lambda (fmt &rest args) + (push (apply #'format fmt args) messages) + nil))) + (should-not (cj/keep--load-local-config))) + (should (seq-find (lambda (m) (string-match-p "google-keep.*local config" m)) + messages)))) + (delete-file file)))) + +(provide 'test-google-keep-config--local-config) +;;; test-google-keep-config--local-config.el ends here diff --git a/tests/test-init-defer-games.el b/tests/test-init-defer-games.el index f3ec94de..4f349908 100644 --- a/tests/test-init-defer-games.el +++ b/tests/test-init-defer-games.el @@ -42,5 +42,36 @@ load failed to define malyon." (should (featurep 'games-config)) (should (equal malyon-stories-directory "/tmp/games-defer-test/text.games/")))) +(defun test-init-defer-games--declaration-installs-p (init package) + "Return non-nil when INIT (init.el's text) declares PACKAGE in an installing form. +A `use-package' form that carries `:ensure nil' or `:load-path' does not +install (use-package suppresses `use-package-always-ensure' for both), so +the check rejects those rather than accepting any form that names the package." + (and (string-match (format "^(use-package %s\\b\\([^\n]*\\))[ \t]*$" + (regexp-quote package)) + init) + (let ((args (match-string 1 init))) + (not (string-match-p ":ensure nil\\|:load-path" args))))) + +(ert-deftest test-init-defer-games-init-declares-both-packages () + "Normal: init.el declares malyon and 2048-game in forms that install them. +`use-package-always-ensure' is the installer for these two. a8571eff dropped +the declarations along with the eager require, and both packages silently +vanished on the next rebuild while every other test still passed." + (let ((init (with-temp-buffer + (insert-file-contents (expand-file-name "init.el" default-directory)) + (buffer-string)))) + (should (test-init-defer-games--declaration-installs-p init "malyon")) + (should (test-init-defer-games--declaration-installs-p init "2048-game")))) + +(ert-deftest test-init-defer-games-declaration-check-rejects-non-installing-forms () + "Boundary: the declaration check refuses forms use-package would not install." + (should-not (test-init-defer-games--declaration-installs-p + "(use-package malyon :ensure nil :defer t)\n" "malyon")) + (should-not (test-init-defer-games--declaration-installs-p + "(use-package malyon :load-path \"~/x\" :defer t)\n" "malyon")) + (should (test-init-defer-games--declaration-installs-p + "(use-package malyon :defer t :commands (malyon))\n" "malyon"))) + (provide 'test-init-defer-games) ;;; test-init-defer-games.el ends here diff --git a/tests/test-integration-recurring-events.el b/tests/test-integration-recurring-events.el index 8339d167..44ddfb00 100644 --- a/tests/test-integration-recurring-events.el +++ b/tests/test-integration-recurring-events.el @@ -24,13 +24,22 @@ ;;; Setup and Teardown +(defvar test-integration-recurring-events--saved-tz nil + "The TZ in force before setup pinned it, restored by teardown.") + (defun test-integration-recurring-events-setup () - "Setup for recurring events integration tests." - nil) + "Setup for recurring events integration tests. +Pins TZ to America/Chicago: the fixtures are TZID=America/Chicago and the +assertions expect that zone's local rendering (\"Sat 10:30-11:00\"), so on +any other machine zone the pipeline's correct conversion reads as a failure. +`setenv' on TZ also calls `set-time-zone-rule', which is what the time +functions actually consult." + (setq test-integration-recurring-events--saved-tz (getenv "TZ")) + (setenv "TZ" "America/Chicago")) (defun test-integration-recurring-events-teardown () - "Teardown for recurring events integration tests." - nil) + "Teardown for recurring events integration tests: restore the machine TZ." + (setenv "TZ" test-integration-recurring-events--saved-tz)) ;;; Test Data diff --git a/tests/test-music-config--append-track-to-m3u-file.el b/tests/test-music-config--append-track-to-m3u-file.el index be0cbd8e..cc40438c 100644 --- a/tests/test-music-config--append-track-to-m3u-file.el +++ b/tests/test-music-config--append-track-to-m3u-file.el @@ -39,7 +39,8 @@ "Append to brand new empty M3U file." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (track-path (expand-file-name "artist/song.mp3" cj/music-root)) (expected-relative "artist/song.mp3")) (cj/music--append-track-to-m3u-file track-path m3u-file) @@ -53,6 +54,7 @@ (test-music-config--append-track-to-m3u-file-setup) (unwind-protect (let* ((existing-content "first.mp3\n") + (cj/music-root (cj/create-test-base-dir)) (m3u-file (cj/create-temp-test-file-with-content existing-content "test-playlist-")) (track-path (expand-file-name "second.mp3" cj/music-root)) (expected-relative "second.mp3")) @@ -68,6 +70,7 @@ (test-music-config--append-track-to-m3u-file-setup) (unwind-protect (let* ((existing-content "first.mp3") + (cj/music-root (cj/create-test-base-dir)) (m3u-file (cj/create-temp-test-file-with-content existing-content "test-playlist-")) (track-path (expand-file-name "second.mp3" cj/music-root)) (expected-relative "second.mp3")) @@ -82,7 +85,8 @@ "Multiple appends to same file all succeed (allows duplicates)." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (track1 (expand-file-name "track1.mp3" cj/music-root)) (track2 (expand-file-name "track2.mp3" cj/music-root)) (track1-duplicate (expand-file-name "track1.mp3" cj/music-root)) @@ -98,13 +102,157 @@ (concat rel1 "\n" rel2 "\n" rel1 "\n")))))) (test-music-config--append-track-to-m3u-file-teardown))) +;;; Normal Cases: round-trip with the reader + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-round-trips-through-the-reader () + "Normal: the same-directory case round-trips through the reader. +A positive control only. With the playlist and the music root in one +directory both candidate bases produce the same string, so this passes +against the old writer too — the discriminating cases are the two tests +below, which put the bases at different depths." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (cj/music-root base) + (m3u-file (cj/create-temp-test-file "test-playlist-")) + (track-path (expand-file-name "artist/song.mp3" base))) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-round-trips-outside-the-music-root () + "Normal/regression: a playlist living outside `cj/music-root' round-trips. +This is the case the old writer got wrong. It based every relative path on +`cj/music-root' wherever the playlist sat, while the reader resolved against +the playlist's directory. Inside the music root the two coincide, which is +why the defect stayed invisible until a playlist moved out of it." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + ;; The layout mirrors the real one: playlists/ and audio/ are siblings + ;; under mpd/, and the music root is a separate tree at a different depth. + ;; The depth difference is load-bearing -- put the music root alongside + ;; playlists/ instead and both bases yield the same relative path, so the + ;; test passes against the broken writer and proves nothing. + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (audio (expand-file-name "mpd/audio/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "ambience.m3u" playlists)) + (track-path (expand-file-name "rain-loop.mp3" audio))) + (make-directory playlists t) + (make-directory audio t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-under-playlist-dir-is-relative () + "Normal: a track under the playlist's directory is written relative to it. +The music root sits at a different depth on purpose. Put it alongside the +playlist directory instead and both candidate bases produce the same string, +so the assertion would hold against a writer using either one." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "album.m3u" playlists)) + (track-path (expand-file-name "sub/song.mp3" playlists))) + (make-directory (expand-file-name "sub/" playlists) t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) "sub/song.mp3\n"))) + (should (equal (cj/music--m3u-file-tracks m3u-file) (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-sibling-dir-is-absolute () + "Normal: a track outside the playlist's directory is written absolute. +A sibling would otherwise come out as \"../audio/x.mp3\". Absolute is the +convention for cross-tree references here, and it survives the playlist being +moved again later, which a ../ chain does not." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (audio (expand-file-name "mpd/audio/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "ambience.m3u" playlists)) + (track-path (expand-file-name "rain-loop.mp3" audio))) + (make-directory playlists t) + (make-directory audio t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) (concat track-path "\n")))) + (should (equal (cj/music--m3u-file-tracks m3u-file) (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-normal-deep-parent-chain-goes-absolute () + "Normal: a track several levels away is written absolute, not as a ../ chain. +This is the case the absolute fallback exists for. A four-level chain is +unreadable and breaks the moment the playlist moves, so distance from the +playlist is exactly when an absolute path earns its keep." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "a/b/c/playlists/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "deep.m3u" playlists)) + (track-path (expand-file-name "faraway/song.mp3" base))) + (make-directory playlists t) + (make-directory (expand-file-name "faraway/" base) t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + ;; Four hops up (playlists -> c -> b -> a -> base) would be the + ;; relative form; the writer declines it and emits the absolute path. + (should (string= (buffer-string) (concat track-path "\n")))) + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + ;;; Boundary Cases +(ert-deftest test-music-config--append-track-to-m3u-file-boundary-dotdot-named-dir-stays-relative () + "Boundary: a directory whose name merely begins with two dots stays relative. +This is the input the relative-vs-absolute test actually turns on. The check +looks for a leading \"../\", so a real subdirectory named \"..hidden\" is under +the playlist and must not be mistaken for an escape. Loosening the check to +\"..\" would break exactly this case and nothing else in the suite would catch +it." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (playlists (expand-file-name "mpd/playlists/" base)) + (cj/music-root (expand-file-name "music/" base)) + (m3u-file (expand-file-name "p.m3u" playlists)) + (track-path (expand-file-name "..hidden/song.mp3" playlists))) + (make-directory (expand-file-name "..hidden/" playlists) t) + (make-directory cj/music-root t) + (with-temp-buffer (write-file m3u-file)) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) "..hidden/song.mp3\n"))) + (should (equal (cj/music--m3u-file-tracks m3u-file) (list track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + (ert-deftest test-music-config--append-track-to-m3u-file-boundary-very-long-path-appends-successfully () "Append very long track path without truncation." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) ;; Create a relative path that's ~450 chars long (relative-path (concat (make-string 440 ?a) "/song.mp3")) (track-path (expand-file-name relative-path cj/music-root))) @@ -119,7 +267,8 @@ "Append path with unicode characters preserves UTF-8 encoding." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (relative-path "中文/artist-名前/song🎵.mp3") (track-path (expand-file-name relative-path cj/music-root))) (cj/music--append-track-to-m3u-file track-path m3u-file) @@ -132,7 +281,8 @@ "Append path with spaces and special characters." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect - (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) + (let* ((cj/music-root (cj/create-test-base-dir)) + (m3u-file (cj/create-temp-test-file "test-playlist-")) (relative-path "Artist Name/Album (2024)/01 - Song's Title [Remix].mp3") (track-path (expand-file-name relative-path cj/music-root))) (cj/music--append-track-to-m3u-file track-path m3u-file) @@ -146,6 +296,7 @@ (test-music-config--append-track-to-m3u-file-setup) (unwind-protect (let* ((existing-content "#EXTM3U\n#EXTINF:-1,Radio Station\nhttp://stream.url/radio\n") + (cj/music-root (cj/create-test-base-dir)) (m3u-file (cj/create-temp-test-file-with-content existing-content "test-playlist-")) (relative-path "local-track.mp3") (track-path (expand-file-name relative-path cj/music-root))) @@ -156,6 +307,73 @@ (concat existing-content relative-path "\n"))))) (test-music-config--append-track-to-m3u-file-teardown))) +;;; Boundary Cases: symlinked playlists + +(defun test-music-config--append--make-symlinked-playlist (base content link-depth) + "Create a playlist whose deployed path is a symlink, and return that path. +CONTENT is written to the real file. LINK-DEPTH controls how long the link +string is, which is the whole point: `file-attributes' does not follow +symlinks, so a writer sizing the file that way reads the length of the link +rather than the content." + (let* ((deployed (expand-file-name "deployed/" base)) + (deep (expand-file-name (mapconcat #'identity + (make-list link-depth "longdirname") + "/") + base)) + (real (expand-file-name "p.m3u" deep)) + (link (expand-file-name "p.m3u" deployed))) + (make-directory deep t) + (make-directory deployed t) + (with-temp-buffer (insert content) (write-file real)) + (make-symbolic-link (file-relative-name real deployed) link t) + link)) + +(ert-deftest test-music-config--append-track-to-m3u-file-boundary-symlink-longer-than-content () + "Boundary: appending to a symlinked playlist whose link string is longer than +its content must not signal. Sizing the file with `file-attributes' returns +the link's length, so the read range falls outside the file, nothing is +inserted, and `char-after' hands nil to a numeric comparison. Measured on the +real deployed set: 31 of 100 symlinked playlists are in this state." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + (let* ((base (cj/create-test-base-dir)) + (m3u-file (test-music-config--append--make-symlinked-playlist + base "https://example.com/s.mp3\n" 8)) + (track-path (expand-file-name "song.mp3" (file-name-directory m3u-file)))) + (should (> (file-attribute-size (file-attributes m3u-file)) + (file-attribute-size (file-attributes (file-truename m3u-file))))) + (cj/music--append-track-to-m3u-file track-path m3u-file) + ;; The seeded line is a stream URL, which the reader passes through, so + ;; both entries come back. + (should (equal (cj/music--m3u-file-tracks m3u-file) + (list "https://example.com/s.mp3" track-path)))) + (test-music-config--append-track-to-m3u-file-teardown))) + +(ert-deftest test-music-config--append-track-to-m3u-file-boundary-symlink-no-spurious-blank-line () + "Boundary: a symlinked playlist already ending in a newline gains no blank line. +The trailing-newline probe reads a byte chosen from the wrong size, so it +misreads a terminated file as unterminated and prepends a newline. All 100 +symlinked playlists in the deployed set read the wrong byte this way." + (test-music-config--append-track-to-m3u-file-setup) + (unwind-protect + ;; Content deliberately longer than the link string, so the misread byte + ;; still lands inside the file. That separates this from the sibling test + ;; above: here the probe reads a valid but wrong byte and silently + ;; misjudges, rather than reading past the end and signalling. + (let* ((base (cj/create-test-base-dir)) + (content (mapconcat (lambda (i) (format "track-%03d-with-a-longish-name.mp3" i)) + (number-sequence 1 12) "\n")) + (m3u-file (test-music-config--append--make-symlinked-playlist + base (concat content "\n") 2)) + (track-path (expand-file-name "second.mp3" (file-name-directory m3u-file)))) + (should (< (file-attribute-size (file-attributes m3u-file)) + (file-attribute-size (file-attributes (file-truename m3u-file))))) + (cj/music--append-track-to-m3u-file track-path m3u-file) + (with-temp-buffer + (insert-file-contents m3u-file) + (should (string= (buffer-string) (concat content "\nsecond.mp3\n"))))) + (test-music-config--append-track-to-m3u-file-teardown))) + ;;; Error Cases (ert-deftest test-music-config--append-track-to-m3u-file-error-nonexistent-file-signals-error () @@ -172,6 +390,9 @@ "Signal error when M3U file is read-only." (test-music-config--append-track-to-m3u-file-setup) (unwind-protect + ;; No `cj/music-root' rebinding here: the writable-p guard signals before + ;; any path computation runs, so binding it would imply a dependency the + ;; read-only path does not have. (let* ((m3u-file (cj/create-temp-test-file "test-playlist-")) (track-path "/home/user/music/song.mp3")) ;; Make file read-only diff --git a/tests/test-package-resilience.el b/tests/test-package-resilience.el new file mode 100644 index 00000000..d5fdde4a --- /dev/null +++ b/tests/test-package-resilience.el @@ -0,0 +1,504 @@ +;;; test-package-resilience.el --- Tests for surviving failed package installs -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for package-resilience.el, which keeps a failed package download from +;; aborting init. The regression these guard is concrete: early-init.el sets +;; `debug-on-error' during startup so config errors are loud, and that disarms +;; the `condition-case-unless-debug' inside `use-package-ensure-elpa', so one +;; transient download error dropped a fresh install into the debugger with two +;; thirds of the config unloaded. +;; +;; The fakes below stand in for the package archive so no test touches the +;; network or the real elpa directory. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'package-resilience) + +;;; ------------------------------- Fake registry ------------------------------- + +(defvar test-pkg-res--installed nil + "Package symbols the fake registry considers installed.") + +(defvar test-pkg-res--install-log nil + "Packages `package-install' was called with, newest first.") + +(defvar test-pkg-res--failures nil + "Alist of (PACKAGE . N): the next N install attempts for PACKAGE signal.") + +(defvar test-pkg-res--dynamic-state nil + "Captured dynamic state at each `package-install' call, newest first.") + +(defun test-pkg-res--should-fail-p (package) + "Return non-nil when this attempt at PACKAGE should signal, and count it." + (let ((cell (assq package test-pkg-res--failures))) + (when (and cell (> (cdr cell) 0)) + (setcdr cell (1- (cdr cell))) + t))) + +(defun test-pkg-res--install (package) + "Fake `package-install' for PACKAGE: record the call, then fail or install." + (push package test-pkg-res--install-log) + (push (list :debug-on-error debug-on-error + :find-file-hook find-file-hook + :prog-mode-hook prog-mode-hook + :lisp-data-mode-hook lisp-data-mode-hook + :emacs-lisp-mode-hook emacs-lisp-mode-hook) + test-pkg-res--dynamic-state) + (if (test-pkg-res--should-fail-p package) + (signal 'file-error (list "https://elpa.example.invalid/x.tar" "No Data")) + (push package test-pkg-res--installed))) + +(defmacro test-pkg-res--with-registry (available installed failures &rest body) + "Run BODY against a fake package registry. +AVAILABLE lists package symbols the archives carry, INSTALLED those already +installed, and FAILURES is an alist of (PACKAGE . N) attempts that signal." + (declare (indent 3) (debug t)) + `(let ((test-pkg-res--installed (copy-sequence ,installed)) + (test-pkg-res--install-log nil) + (test-pkg-res--failures (copy-tree ,failures)) + (test-pkg-res--dynamic-state nil) + (cj/failed-package-installs nil) + (cj/failed-source-package-installs nil) + (cj/package-install-retry-delay 0) + ;; Both of these accumulate across a whole session by design, so a + ;; test that leaves them set changes what a later test does: an + ;; unbound failure counter tripped the circuit breaker and three + ;; install tests stopped installing anything at all. + (cj/--package-retry-spent 0.0) + (cj/--package-consecutive-failures 0) + (package-archive-contents (mapcar #'list ,available))) + (cl-letf (((symbol-function 'package-installed-p) + (lambda (pkg &rest _) (and (memq pkg test-pkg-res--installed) t))) + ((symbol-function 'package-install) + (lambda (pkg &rest _) (test-pkg-res--install pkg))) + ((symbol-function 'package-refresh-contents) (lambda (&rest _) nil)) + ((symbol-function 'package-read-all-archive-contents) (lambda (&rest _) nil)) + ((symbol-function 'sleep-for) (lambda (&rest _) nil))) + ,@body))) + +;;; --------------------------- Resolving :ensure args -------------------------- + +(ert-deftest test-package-resilience-packages-resolves-t-to-name () + "Normal: an :ensure of t resolves to the use-package form's own name." + (should (equal '(foo) (cj/--package-ensure-packages 'foo '(t))))) + +(ert-deftest test-package-resilience-packages-resolves-explicit-symbol () + "Normal: an explicit :ensure symbol names a different package." + (should (equal '(bar) (cj/--package-ensure-packages 'foo '(bar))))) + +(ert-deftest test-package-resilience-packages-nil-ensure-is-empty () + "Boundary: :ensure nil requests no package at all." + (should (equal '() (cj/--package-ensure-packages 'foo '(nil))))) + +(ert-deftest test-package-resilience-packages-unwraps-pinned-cons () + "Boundary: a pinned (PACKAGE . ARCHIVE) cell resolves to the package symbol." + (should (equal '(bar) (cj/--package-ensure-packages 'foo '((bar . "melpa")))))) + +(ert-deftest test-package-resilience-packages-accepts-string-name () + "Boundary: a use-package form named with a string still resolves to a symbol." + (should (equal '(foo) (cj/--package-ensure-packages "foo" '(t))))) + +(ert-deftest test-package-resilience-packages-handles-several-ensures () + "Boundary: several :ensure keywords resolve to several packages." + (should (equal '(bar baz) (cj/--package-ensure-packages 'foo '(bar baz))))) + +;;; ------------------------------ Installing ---------------------------------- + +(ert-deftest test-package-resilience-installs-missing-package () + "Normal: a missing package is installed and nothing is recorded as failed." + (test-pkg-res--with-registry '(foo) '() '() + (cj/package-ensure 'foo '(t) nil) + (should (equal '(foo) test-pkg-res--install-log)) + (should (memq 'foo test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-skips-installed-package () + "Normal: an already-installed package is never downloaded again." + (test-pkg-res--with-registry '(foo) '(foo) '() + (cj/package-ensure 'foo '(t) nil) + (should-not test-pkg-res--install-log) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-survives-failure-under-debug-on-error () + "Error: a failed install is recorded, not signalled, even with debug-on-error. +This is the regression: `condition-case-unless-debug' inside use-package does +not catch while `debug-on-error' is non-nil, so a transient download error +aborted init in place." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((debug-on-error t)) + (cj/package-ensure 'foo '(t) nil) + (should (memq 'foo cj/failed-package-installs)) + (should-not (memq 'foo test-pkg-res--installed))))) + +(ert-deftest test-package-resilience-retries-transient-failure () + "Error: a download that fails once and then succeeds installs on the retry." + (test-pkg-res--with-registry '(foo) '() '((foo . 1)) + (cj/package-ensure 'foo '(t) nil) + (should (= 2 (length test-pkg-res--install-log))) + (should (memq 'foo test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-stops-after-configured-retries () + "Boundary: a package that always fails is attempted retries-plus-one times." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((cj/package-install-retries 2)) + (cj/package-ensure 'foo '(t) nil) + (should (= 3 (length test-pkg-res--install-log))) + (should (memq 'foo cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-does-not-retry-unknown-package () + "Boundary: a package no archive carries is attempted once, then recorded. +Retrying a name the archives have never heard of only burns refreshes." + (test-pkg-res--with-registry '() '() '((foo . 999)) + (let ((cj/package-install-retries 2)) + (cj/package-ensure 'foo '(t) nil) + (should (= 1 (length test-pkg-res--install-log))) + (should (memq 'foo cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-inhibits-editing-hooks-during-install () + "Error: editing hooks are silenced while a package installs. +Installation generates autoloads by visiting .el files, so a hook belonging to +a package that failed earlier would otherwise break unrelated installs." + (test-pkg-res--with-registry '(foo) '() '() + (let ((find-file-hook '(ignore)) + (prog-mode-hook '(ignore)) + (lisp-data-mode-hook '(ignore)) + (emacs-lisp-mode-hook '(ignore))) + (cj/package-ensure 'foo '(t) nil) + (let ((seen (car test-pkg-res--dynamic-state))) + (should-not (plist-get seen :find-file-hook)) + (should-not (plist-get seen :prog-mode-hook)) + (should-not (plist-get seen :lisp-data-mode-hook)) + (should-not (plist-get seen :emacs-lisp-mode-hook)) + (should-not (plist-get seen :debug-on-error)))))) + +(ert-deftest test-package-resilience-records-each-failure-once () + "Boundary: repeated ensure calls for one package record it a single time." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (cj/package-ensure 'foo '(t) nil) + (cj/package-ensure 'foo '(t) nil) + (should (equal '(foo) cj/failed-package-installs)))) + +;;; ------------------------------ Retry budget --------------------------------- + +(ert-deftest test-package-resilience-budget-caps-retrying () + "Boundary: with the retry budget spent, a failure gets its one attempt only. +An offline machine fails every package, so an uncapped per-package retry would +turn the abort this module removes into a startup that appears to hang." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((cj/package-install-retries 2) + (cj/--package-retry-spent 999.0)) + (cj/package-ensure 'foo '(t) nil) + (should (= 1 (length test-pkg-res--install-log))) + (should (memq 'foo cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-budget-still-records-failures () + "Boundary: a package skipped for budget is still recorded and reportable." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (let ((cj/--package-retry-spent 999.0)) + (cj/package-ensure 'foo '(t) nil) + (should (equal '(foo) (cj/package-still-missing)))))) + +(ert-deftest test-package-resilience-budget-accrues-across-packages () + "Error: retry time spent on one package counts against the next one's budget. +The budget is per session, not per package, which is what bounds a machine +offline for all ~190 of them. The clock is advanced ten seconds per reading so +the accrual is real rather than an artifact of a mocked sleep." + (test-pkg-res--with-registry '(foo bar) '() '((foo . 999) (bar . 999)) + (let ((cj/package-install-retries 2) + (cj/package-install-retry-budget 15.0) + (cj/--package-retry-spent 0.0) + (clock 0.0)) + (cl-letf (((symbol-function 'float-time) + (lambda (&rest _) (setq clock (+ clock 10.0))))) + (cj/package-ensure 'foo '(t) nil) + (cj/package-ensure 'bar '(t) nil)) + ;; foo: one attempt plus two retries, spending 20s. bar: one attempt, + ;; because foo already overspent the shared budget. + (should (= 4 (length test-pkg-res--install-log))) + (should (> cj/--package-retry-spent cj/package-install-retry-budget))))) + +;;; ----------------------------- Circuit breaker ------------------------------- + +(ert-deftest test-package-resilience-stops-attempting-after-failure-run () + "Error: enough failures in a row and later packages are recorded untried. +Offline, nothing populates the archive list, so every single attempt pays a +full `package-refresh-contents' before failing. Across ~190 packages that is +the dominant cost, and no retry ceiling bounds it." + (test-pkg-res--with-registry '(a b c) '() '((a . 999) (b . 999) (c . 999)) + (let ((cj/package-install-retries 0) + (cj/package-install-failure-limit 2)) + (cj/package-ensure 'a '(t) nil) + (cj/package-ensure 'b '(t) nil) + (cj/package-ensure 'c '(t) nil) + ;; a and b were tried; c was not, because the run had already reached 2. + (should (equal '(b a) test-pkg-res--install-log)) + (should (memq 'c cj/failed-package-installs))))) + +(ert-deftest test-package-resilience-failure-run-resets-on-success () + "Boundary: one success clears the run, so an unlucky package is not fatal. +The breaker exists to detect a dead network, not to give up after N scattered +failures across an otherwise healthy install." + (test-pkg-res--with-registry '(a b c) '() '((a . 999) (c . 999)) + (let ((cj/package-install-retries 0) + (cj/package-install-failure-limit 2)) + (cj/package-ensure 'a '(t) nil) ; fails, run = 1 + (cj/package-ensure 'b '(t) nil) ; succeeds, run = 0 + (cj/package-ensure 'c '(t) nil) ; fails, run = 1, still under the limit + (should (equal '(c b a) test-pkg-res--install-log))))) + +(ert-deftest test-package-resilience-installed-package-does-not-clear-run () + "Boundary: a package that was already present tells us nothing about the net. +Counting it as a success would reset the run on every built-in-backed form and +the breaker would never trip on an offline machine." + (test-pkg-res--with-registry '(a b c) '(b) '((a . 999) (c . 999)) + (let ((cj/package-install-retries 0) + (cj/package-install-failure-limit 2)) + (cj/package-ensure 'a '(t) nil) ; fails, run = 1 + (cj/package-ensure 'b '(t) nil) ; already installed, untouched + (cj/package-ensure 'c '(t) nil) ; fails, run = 2 + (should (equal '(c a) test-pkg-res--install-log)) + (should (cj/--package-giving-up-p))))) + +;;; --------------------- Packages installed from source (:vc) ------------------ + +(defun test-pkg-res--vc-orig (fails) + "Return a fake `use-package-vc-install' that signals when FAILS is non-nil." + (lambda (arg &optional _local-path) + (push (car arg) test-pkg-res--install-log) + (if fails + (signal 'error (list "Cloning failed: Permission denied (publickey)")) + (push (car arg) test-pkg-res--installed)))) + +(ert-deftest test-package-resilience-vc-install-succeeds-quietly () + "Normal: a working source install is not recorded as a failure." + (test-pkg-res--with-registry '() '() '() + (cj/--package-vc-install-guard (test-pkg-res--vc-orig nil) '(gloss nil nil)) + (should (memq 'gloss test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-vc-install-survives-failed-clone () + "Error: a failed clone is recorded, not signalled, even with debug-on-error. +`:vc' forms route around `use-package-ensure-function' entirely and +`use-package-vc-install' has no error handling, so without this guard a fresh +machine lacking credentials for the git host aborts init exactly as before." + (test-pkg-res--with-registry '() '() '() + (let ((debug-on-error t)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(gloss nil nil)) + (should (memq 'gloss cj/failed-source-package-installs)) + (should (memq 'gloss (cj/package-still-missing))) + ;; Never the archive list: `package-install' cannot recover a source + ;; package, and for one that also exists on an archive it would install + ;; the archive build instead of the checkout that was asked for. + (should-not (memq 'gloss cj/failed-package-installs)) + (should-not (memq 'gloss test-pkg-res--installed))))) + +(ert-deftest test-package-resilience-vc-failure-counts-toward-breaker () + "Error: a failed clone counts toward the consecutive-failure run. +No credentials means every source package fails, the same shape as no network." + (test-pkg-res--with-registry '() '() '() + (let ((cj/package-install-failure-limit 2)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(gloss nil nil)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(chime nil nil)) + (should (cj/--package-giving-up-p))))) + +(ert-deftest test-package-resilience-vc-skipped-once-breaker-tripped () + "Boundary: with the breaker tripped a source install is recorded untried." + (test-pkg-res--with-registry '() '() '() + (let ((cj/--package-consecutive-failures 99)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig t) '(gloss nil nil)) + (should-not test-pkg-res--install-log) + (should (memq 'gloss cj/failed-source-package-installs))))) + +(ert-deftest test-package-resilience-vc-installed-package-passes-through () + "Boundary: an already-installed source package neither counts nor records. +It says nothing about whether the git host is reachable, so treating it as a +success would reset the run and stop the breaker ever tripping." + (test-pkg-res--with-registry '() '(gloss) '() + (let ((cj/--package-consecutive-failures 3)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig nil) '(gloss nil nil)) + (should (= 3 cj/--package-consecutive-failures)) + (should-not cj/failed-package-installs)))) + +(ert-deftest test-package-resilience-vc-success-clears-failure-run () + "Boundary: a clone that works clears the run, like any other install." + (test-pkg-res--with-registry '() '() '() + (let ((cj/--package-consecutive-failures 3)) + (cj/--package-vc-install-guard (test-pkg-res--vc-orig nil) '(gloss nil nil)) + (should (= 0 cj/--package-consecutive-failures))))) + +;;; --------------------------------- Retrying ---------------------------------- + +(ert-deftest test-package-resilience-retry-clears-recovered-package () + "Normal: retrying installs a package that is now reachable and clears it." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs '(foo)) + (cj/retry-failed-package-installs) + (should (memq 'foo test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-retry-converges-on-cascade () + "Boundary: a package installable only on a later pass still converges. +A failed package leaves hooks that break other installs, so recovery has to +keep passing over the set until a pass installs nothing new." + (test-pkg-res--with-registry '(foo bar) '() '((bar . 1)) + (setq cj/failed-package-installs '(foo bar)) + (cj/retry-failed-package-installs) + (should (memq 'foo test-pkg-res--installed)) + (should (memq 'bar test-pkg-res--installed)) + (should-not cj/failed-package-installs))) + +(ert-deftest test-package-resilience-retry-leaves-source-packages-alone () + "Boundary: retrying never runs `package-install' on a source package. +It cannot recover one, and for a source package that also exists on an archive +it would install the archive build instead of the checkout that was declared, +leaving `package-installed-p' true and the source install permanently skipped." + (test-pkg-res--with-registry '(gloss) '() '() + (setq cj/failed-source-package-installs '(gloss)) + (cj/retry-failed-package-installs) + (should-not test-pkg-res--install-log) + (should (equal '(gloss) (cj/package-still-missing))))) + +(ert-deftest test-package-resilience-retry-works-with-empty-archive-list () + "Error: recovery still attempts installs when no archive list is loaded yet. +This is the case the command exists for: a laptop that booted before its wifi +came up has an empty `package-archive-contents', and screening recorded +packages against it would make the command a silent no-op right when the user +finally has a network. `package-install' populates the archives itself." + (test-pkg-res--with-registry '() '() '() + (setq cj/failed-package-installs '(foo bar)) + (should-not package-archive-contents) + (cj/retry-failed-package-installs) + (should (equal '(bar foo) test-pkg-res--install-log)) + (should-not (cj/package-still-missing)))) + +(ert-deftest test-package-resilience-retry-terminates-when-impossible () + "Error: a package that can never install terminates the loop and stays listed." + (test-pkg-res--with-registry '(foo) '() '((foo . 999)) + (setq cj/failed-package-installs '(foo)) + (cj/retry-failed-package-installs) + (should (equal '(foo) cj/failed-package-installs)))) + +(ert-deftest test-package-resilience-retry-with-nothing-failed-is-quiet () + "Boundary: retrying an empty failure set installs nothing." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs nil) + (cj/retry-failed-package-installs) + (should-not test-pkg-res--install-log))) + +;;; -------------------------------- Reporting ---------------------------------- + +(ert-deftest test-package-resilience-report-is-silent-when-clean () + "Normal: a run with no failed installs raises no warning." + (test-pkg-res--with-registry '() '() '() + (let ((warned nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (&rest _) (setq warned t)))) + (cj/report-failed-package-installs) + (should-not warned))))) + +(ert-deftest test-package-resilience-still-missing-does-not-mutate-records () + "Error: reading the missing set leaves both record lists intact. +`append' does not copy its last argument and `delete-dups' splices, so the +obvious spelling edits `cj/failed-source-package-installs' in place. Reading a +value must not destroy it, least of all from the startup report." + (test-pkg-res--with-registry '() '() '() + (setq cj/failed-package-installs '(foo shared)) + (setq cj/failed-source-package-installs '(gloss shared chime)) + (cj/package-still-missing) + (should (equal '(foo shared) cj/failed-package-installs)) + (should (equal '(gloss shared chime) cj/failed-source-package-installs)))) + +(ert-deftest test-package-resilience-report-omits-package-installed-since () + "Boundary: a package that arrived later as a dependency is not reported. +It failed on its own use-package form, so it is on the recorded list, but it is +present now and there is nothing for the user to do about it." + (test-pkg-res--with-registry '(foo bar) '(foo) '() + (setq cj/failed-package-installs '(foo bar)) + (should (equal '(bar) (cj/package-still-missing))) + (let ((message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should (string-match-p "bar" message-text)) + (should-not (string-match-p "foo" message-text)))))) + +(ert-deftest test-package-resilience-report-silent-when-all-arrived-since () + "Boundary: recorded failures that are all installed now raise no warning." + (test-pkg-res--with-registry '(foo) '(foo) '() + (setq cj/failed-package-installs '(foo)) + (let ((warned nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (&rest _) (setq warned t)))) + (cj/report-failed-package-installs) + (should-not warned))))) + +(ert-deftest test-package-resilience-report-says-when-it-stopped-early () + "Error: a tripped breaker is said out loud, so untried is not read as failed. +Most of a long list would never have been attempted, and reporting those as +install failures would send the user hunting for ~185 individual problems." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs '(foo)) + (let ((cj/--package-consecutive-failures 99) + (message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should (string-match-p "never" message-text)) + ;; Names both causes: a run of failures is a dead network or missing + ;; credentials, and the message should not pick one. + (should (string-match-p "network" message-text)) + (should (string-match-p "credentials" message-text)))))) + +(ert-deftest test-package-resilience-report-omits-early-stop-when-not-tripped () + "Boundary: an ordinary failure is not dressed up as a machine being offline." + (test-pkg-res--with-registry '(foo) '() '() + (setq cj/failed-package-installs '(foo)) + (let ((cj/--package-consecutive-failures 0) + (message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should-not (string-match-p "never" message-text)))))) + +(ert-deftest test-package-resilience-report-warns-and-names-failures () + "Error: failed installs raise one warning that names every package." + (test-pkg-res--with-registry '(foo bar) '() '() + (setq cj/failed-package-installs '(foo bar)) + (let ((message-text nil)) + (cl-letf (((symbol-function 'display-warning) + (lambda (_type msg &rest _) (setq message-text msg)))) + (cj/report-failed-package-installs) + (should message-text) + (should (string-match-p "foo" message-text)) + (should (string-match-p "bar" message-text)))))) + +;;; ---------------------------------- Wiring ----------------------------------- + +;; The guard tests above call the functions directly, which says nothing about +;; whether they are actually reachable from a real startup. If use-package +;; renamed either seam, every test above would still pass while the whole +;; module sat dead -- this repo's recurring failure, a gate that was green +;; because it never ran. + +(ert-deftest test-package-resilience-is-wired-to-use-package () + "Normal: loading the module actually takes over both use-package seams. +`advice-member-p' answers yes for advice attached to a symbol that was never +defined, so it alone would still pass if upstream renamed the function and left +the advice on a dead symbol. That rename is the whole scenario this test +exists for, hence the `fboundp'." + (should (eq use-package-ensure-function #'cj/package-ensure)) + (should (fboundp 'use-package-vc-install)) + (should (advice-member-p #'cj/--package-vc-install-guard + 'use-package-vc-install))) + +(ert-deftest test-package-resilience-reports-at-startup () + "Normal: the end-of-startup report is on `emacs-startup-hook'." + (should (memq #'cj/report-failed-package-installs + (default-value 'emacs-startup-hook)))) + +(provide 'test-package-resilience) +;;; test-package-resilience.el ends here diff --git a/tests/test-prog-general-yas-activation.el b/tests/test-prog-general-yas-activation.el index d6ea42cd..d9ae76e3 100644 --- a/tests/test-prog-general-yas-activation.el +++ b/tests/test-prog-general-yas-activation.el @@ -122,7 +122,11 @@ produces the marker block." "Boundary: <cj + expand in python-ts-mode (a tree-sitter prog-mode-derived mode) produces the marker block. Verifies the snippet reaches modern tree-sitter modes through fundamental-mode inheritance." - (skip-unless (fboundp 'python-ts-mode)) + ;; `python-ts-mode' prompts to install a missing grammar, which a batch run + ;; cannot answer, so skip on the grammar rather than on the mode's existence. + (skip-unless (and (fboundp 'python-ts-mode) + (require 'treesit nil t) + (treesit-ready-p 'python t))) (should (string= (test-prog-general--expand-cj-in-mode #'python-ts-mode) test-prog-general--cj-expected))) diff --git a/tests/test-setup-telega.bats b/tests/test-setup-telega.bats index 3282b9e1..518ecc7b 100644 --- a/tests/test-setup-telega.bats +++ b/tests/test-setup-telega.bats @@ -57,11 +57,11 @@ setup() { # --------------------------- pull_or_announce_image ----------------------- -@test "pull_or_announce_image: announces the in-Emacs build when no image is set" { +@test "pull_or_announce_image: points at make telega-image when no image is set" { TELEGA_DOCKER_IMAGE="" run pull_or_announce_image [ "$status" -eq 0 ] - [[ "$output" == *"M-x telega-server-build"* ]] + [[ "$output" == *"make telega-image"* ]] } @test "pull_or_announce_image: pulls when TELEGA_DOCKER_IMAGE is set" { diff --git a/tests/test-system-commands-resolve-and-run.el b/tests/test-system-commands-resolve-and-run.el index 7e5146b1..3dae8cda 100644 --- a/tests/test-system-commands-resolve-and-run.el +++ b/tests/test-system-commands-resolve-and-run.el @@ -85,26 +85,34 @@ (put 'test-sc-confirm-cmd 'cj/system-confirm nil))) (ert-deftest test-system-cmd-strong-confirm-decline-aborts () - "Boundary: a strong-confirm var uses yes-or-no-p; declining aborts and -does not run the command." + "Boundary: a strong-confirm var asks a single y/n; declining aborts and +does not run the command. + +The strong path used to demand a typed \"yes\", and this test used to assert +that by erroring if `read-char-choice' was called at all. It now asserts the +opposite, because a long-form prompt is only as safe as it is answerable: on +2026-07-31 one became unanswerable when a second agent session held the +selected window, and the Emacs session had to be killed with buffers unsaved. +What survives the change is the part that mattered -- the prompt still has no +default, so RET and space re-prompt rather than confirming a shutdown." (defvar test-sc-strong-cmd "test-strong-cmd") (put 'test-sc-strong-cmd 'cj/system-confirm 'strong) (unwind-protect - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) nil)) - ((symbol-function 'read-char-choice) - (lambda (&rest _) (error "strong confirm must not use read-char-choice"))) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?n)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (error "strong confirm must not demand a typed yes"))) ((symbol-function 'start-process-shell-command) (lambda (&rest _) (error "shouldn't run")))) (should-error (cj/system-cmd 'test-sc-strong-cmd) :type 'user-error)) (put 'test-sc-strong-cmd 'cj/system-confirm nil))) (ert-deftest test-system-cmd-strong-confirm-accept-runs () - "Normal: a strong-confirm var runs the command when yes-or-no-p returns t." + "Normal: a strong-confirm var runs the command on a single y." (defvar test-sc-strong-cmd-2 "echo strong") (put 'test-sc-strong-cmd-2 'cj/system-confirm 'strong) (let (cmd-line) (unwind-protect - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y)) ((symbol-function 'start-process-shell-command) (lambda (_name _buf c) (setq cmd-line c) 'fake-proc)) ((symbol-function 'set-process-query-on-exit-flag) #'ignore) @@ -114,6 +122,29 @@ does not run the command." (put 'test-sc-strong-cmd-2 'cj/system-confirm nil)) (should (string-match-p "echo strong" cmd-line)))) +(ert-deftest test-system-cmd-strong-confirm-rejects-stray-keys () + "Boundary: the strong prompt offers only y and n, so a stray RET or space +cannot confirm an irreversible command. + +This is the protection the typed-\"yes\" form existed for, kept while the +answer became a single keystroke. Asserted on the accepted-character set +handed to `read-char-choice' rather than on the prompt text, because the set +is what actually decides." + (defvar test-sc-strong-cmd-3 "echo strong") + (put 'test-sc-strong-cmd-3 'cj/system-confirm 'strong) + (let (chars) + (unwind-protect + (cl-letf (((symbol-function 'read-char-choice) + (lambda (_prompt cs &rest _) (setq chars cs) ?n)) + ((symbol-function 'start-process-shell-command) + (lambda (&rest _) (error "shouldn't run")))) + (should-error (cj/system-cmd 'test-sc-strong-cmd-3) :type 'user-error)) + (put 'test-sc-strong-cmd-3 'cj/system-confirm nil)) + (should (equal (sort (copy-sequence chars) #'<) '(?N ?Y ?n ?y))) + (should-not (memq ?\r chars)) + (should-not (memq ?\n chars)) + (should-not (memq ?\s chars)))) + ;;; cj/system-cmd--emacs-service-available-p (ert-deftest test-system-cmd-service-available-true-on-zero-exit () diff --git a/tests/test-system-defaults--warning-display-dead-buffer.el b/tests/test-system-defaults--warning-display-dead-buffer.el new file mode 100644 index 00000000..48c7797e --- /dev/null +++ b/tests/test-system-defaults--warning-display-dead-buffer.el @@ -0,0 +1,103 @@ +;;; test-system-defaults--warning-display-dead-buffer.el --- Dead-buffer guard on deferred warnings -*- lexical-binding: t; -*- + +;;; Commentary: +;; Emacs 31.1's warnings.el defers daemon-startup warnings into a one-shot +;; `after-make-frame-functions' closure that calls `warning--display-buffer' +;; on the first client frame with the *Warnings* buffer object it captured at +;; warning time. If anything killed that buffer in between, `display-buffer' +;; signals inside `make-frame', server.el swallows the error as +;; "-window-system-unsupported", and emacsclient silently retries on $DISPLAY: +;; the session's first frame lands on XWayland. +;; +;; The root fix keeps *Warnings* alive (undead-buffers.el). This is the +;; defense in depth: `cj/warning--display-buffer-if-live' wraps +;; `warning--display-buffer' so a dead buffer is skipped rather than passed +;; on. Load happens once in the shared sandbox (testutil-system-defaults.el); +;; `warning--display-buffer' only exists from Emacs 31, so the end-to-end case +;; skips on older builds while the pure-function cases always run. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(require 'testutil-system-defaults) + +(test-system-defaults--with-load-environment + (test-system-defaults--load)) + +(defun test-system-defaults--recording-orig () + "Return (ORIG . CALLS) where ORIG records every argument into CALLS." + (let ((calls (list nil))) + (cons (lambda (buffer) + (push buffer (car calls)) + 'displayed) + calls))) + +;;; Normal Cases + +(ert-deftest test-system-defaults-warning-guard-passes-live-buffer-through () + "Normal: a live buffer reaches the original and its value is returned." + (let* ((rec (test-system-defaults--recording-orig)) + (buf (generate-new-buffer " *warning-guard-live*"))) + (unwind-protect + (progn + (should (eq 'displayed + (cj/warning--display-buffer-if-live (car rec) buf))) + (should (equal (list buf) (car (cdr rec))))) + (kill-buffer buf)))) + +(ert-deftest test-system-defaults-warning-guard-is-installed () + "Normal: loading system-defaults installs the guard on the deferred display. +From Emacs 31 the advised symbol must actually be defined: pending advice on +an undefined symbol would still count as installed, so a rename upstream +would otherwise silently disable the backstop." + (should (advice-member-p #'cj/warning--display-buffer-if-live + 'warning--display-buffer)) + (when (>= emacs-major-version 31) + (should (fboundp 'warning--display-buffer)))) + +(ert-deftest test-system-defaults-warning-guard-resolves-live-buffer-name () + "Normal: a live buffer's name is resolved and passed through as the buffer." + (let* ((rec (test-system-defaults--recording-orig)) + (buf (generate-new-buffer " *warning-guard-named*"))) + (unwind-protect + (progn + (should (eq 'displayed + (cj/warning--display-buffer-if-live + (car rec) (buffer-name buf)))) + (should (equal (list buf) (car (cdr rec))))) + (kill-buffer buf)))) + +;;; Boundary Cases + +(ert-deftest test-system-defaults-warning-guard-skips-killed-buffer () + "Boundary: a killed buffer never reaches the original; result is nil." + (let* ((rec (test-system-defaults--recording-orig)) + (buf (generate-new-buffer " *warning-guard-dead*"))) + (kill-buffer buf) + (should-not (cj/warning--display-buffer-if-live (car rec) buf)) + (should-not (car (cdr rec))))) + +(ert-deftest test-system-defaults-warning-guard-end-to-end-dead-buffer-does-not-signal () + "Boundary: the real deferred display survives a dead buffer. +Mirrors the live failure: a string condition in `display-buffer-alist' is +what `buffer-match-p' tripped over when the buffer name came back nil." + (skip-unless (fboundp 'warning--display-buffer)) + (let ((buf (generate-new-buffer "*Warnings*")) + (display-buffer-alist '(("^ \\*test-guard\\*" display-buffer-no-window)))) + (kill-buffer buf) + (should-not (warning--display-buffer buf)))) + +;;; Error Cases + +(ert-deftest test-system-defaults-warning-guard-rejects-non-buffer () + "Error: nil, or a name that resolves to no buffer, is skipped without a signal." + (let ((rec (test-system-defaults--recording-orig)) + (missing " *warning-guard-no-such-buffer*")) + (when (get-buffer missing) (kill-buffer missing)) + (should-not (cj/warning--display-buffer-if-live (car rec) nil)) + (should-not (cj/warning--display-buffer-if-live (car rec) missing)) + (should-not (car (cdr rec))))) + +(provide 'test-system-defaults--warning-display-dead-buffer) +;;; test-system-defaults--warning-display-dead-buffer.el ends here diff --git a/tests/test-system-defaults-functions.el b/tests/test-system-defaults-functions.el index 4b647166..09bf9f2a 100644 --- a/tests/test-system-defaults-functions.el +++ b/tests/test-system-defaults-functions.el @@ -55,6 +55,12 @@ ;; so it doesn't leak into a shared batch session. `make test-name' loads ;; every test file into one Emacs; a leaked cwd there breaks the relative ;; loads of every file that follows. +;; Declared special before the `let' below binds it: this file is lexical, +;; so without the defvar the binding is a lexical local, and use-package's +;; own `defcustom' then fails with "Defining as dynamic an already lexical +;; var" (fatal at load since 31.1 moved the defcustom to autoload time). +(defvar use-package-always-ensure) + (let ((default-directory default-directory) (use-package-always-ensure nil)) (cl-letf (((symbol-function 'server-running-p) (lambda (&rest _) t)) diff --git a/tests/test-system-lib-auth-source-secret-value.el b/tests/test-system-lib-auth-source-secret-value.el index ec526cec..27a2696b 100644 --- a/tests/test-system-lib-auth-source-secret-value.el +++ b/tests/test-system-lib-auth-source-secret-value.el @@ -63,5 +63,44 @@ Captures the call args in `test-ass--args'." (test-ass--with-search (list (list :host "h")) (should (null (cj/auth-source-secret-value "h"))))) +;;; Error + +(ert-deftest test-auth-source-secret-value-loads-auth-source-when-absent () + "Error: with `auth-source-search' unavailable, the helper loads auth-source. + +Under `emacs --batch -Q' nothing else pulls auth-source in, so a helper +carrying only a `declare-function' dies with a void-function on the first +lookup. An interactive Emacs hides this completely -- something in init +always has auth-source loaded by the time anyone calls here -- which is why +it surfaced only on the batch calendar sync, and only on the machine whose +feeds resolve through `:secret-host' rather than an inline URL. + +The stubbed `require' installs the entry point the way loading auth-source.el +would, so the call can complete and the return value is checked too." + (let ((required nil)) + (cl-letf (((symbol-function 'auth-source-search) nil) + ((symbol-function 'require) + (lambda (feature &rest _) + (push feature required) + (fset 'auth-source-search + (lambda (&rest _) (list (list :secret "loaded")))) + feature))) + (should (equal "loaded" (cj/auth-source-secret-value "h"))) + (should (memq 'auth-source required))))) + +(ert-deftest test-auth-source-secret-value-does-not-reload-when-present () + "Error: an available `auth-source-search' is used as-is, never re-required. + +An unconditional `require' re-loads auth-source.el over whatever is in place, +replacing a caller's stub mid-call -- which sent a test that meant to fake the +lookup out to the real authinfo, where it hung for twelve seconds on gpg." + (let ((required nil)) + (cl-letf (((symbol-function 'require) + (lambda (feature &rest _) (push feature required) feature)) + ((symbol-function 'auth-source-search) + (lambda (&rest _) (list (list :secret "stubbed"))))) + (should (equal "stubbed" (cj/auth-source-secret-value "h"))) + (should-not (memq 'auth-source required))))) + (provide 'test-system-lib-auth-source-secret-value) ;;; test-system-lib-auth-source-secret-value.el ends here diff --git a/tests/test-system-lib-confirm-destructive.el b/tests/test-system-lib-confirm-destructive.el new file mode 100644 index 00000000..4fc96e21 --- /dev/null +++ b/tests/test-system-lib-confirm-destructive.el @@ -0,0 +1,141 @@ +;;; test-system-lib-confirm-destructive.el --- Tests for cj/confirm-destructive -*- lexical-binding: t; -*- + +;;; Commentary: +;; ERT tests for `cj/confirm-destructive', the confirmation used for +;; irreversible actions: file destruction, overwrites, power-off. +;; +;; The contract has two halves, and they pull against each other: +;; +;; 1. One keystroke. This replaced a typed-"yes" prompt on 2026-07-31, after +;; one became unanswerable -- a second agent session held the selected +;; window while the prompt waited in another frame, so keystrokes went to a +;; terminal and the Emacs session had to be killed with buffers unsaved. A +;; long-form prompt is only as safe as it is answerable. +;; +;; 2. No default. Only y and n answer. A stray RET or space re-prompts +;; instead of confirming, which is the accidental-confirm protection the +;; long form existed for, and it survives the change. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'system-lib) + +;;; Normal Cases + +(ert-deftest test-system-lib-confirm-destructive-returns-t-on-y () + "Normal: a y answer confirms." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y))) + (should (eq (cj/confirm-destructive "Really? ") t)))) + +(ert-deftest test-system-lib-confirm-destructive-returns-nil-on-n () + "Normal: an n answer declines." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?n))) + (should (eq (cj/confirm-destructive "Really? ") nil)))) + +;;; Boundary Cases + +(ert-deftest test-system-lib-confirm-destructive-accepts-uppercase () + "Boundary: a capital Y confirms and a capital N declines, so the answer +does not depend on the shift key or caps lock." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?Y))) + (should (eq (cj/confirm-destructive "Really? ") t))) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?N))) + (should (eq (cj/confirm-destructive "Really? ") nil)))) + +(ert-deftest test-system-lib-confirm-destructive-offers-only-y-and-n () + "Boundary: RET, space and every other key are refused. + +This is the protection that justified the old typed-\"yes\" form, kept now +that the answer is a single keystroke. Asserted on the character set handed +to `read-char-choice', which is what actually decides, rather than on the +prompt text, which only describes." + (let (chars) + (cl-letf (((symbol-function 'read-char-choice) + (lambda (_prompt cs &rest _) (setq chars cs) ?n))) + (cj/confirm-destructive "Really? ")) + (should (equal (sort (copy-sequence chars) #'<) '(?N ?Y ?n ?y))) + (should-not (memq ?\r chars)) + (should-not (memq ?\n chars)) + (should-not (memq ?\s chars)))) + +(ert-deftest test-system-lib-confirm-destructive-is-single-keystroke () + "Boundary: it never routes through `yes-or-no-p'. + +The regression this file guards. Binding `use-short-answers' to nil for the +call, which is what the old implementation did, is exactly the shape that +produced an unanswerable prompt." + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (error "must not demand a typed yes")))) + (should (eq (cj/confirm-destructive "Really? ") t)))) + +(ert-deftest test-system-lib-confirm-destructive-ignores-short-answer-setting () + "Boundary: the answer is one key whether or not `use-short-answers' is set. +The global default is t, but nothing about this prompt should depend on it." + (dolist (setting '(t nil)) + (let ((use-short-answers setting)) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ?y)) + ((symbol-function 'yes-or-no-p) + (lambda (&rest _) (error "must not demand a typed yes")))) + (should (eq (cj/confirm-destructive "Really? ") t)))))) + +(ert-deftest test-system-lib-confirm-destructive-discards-type-ahead () + "Boundary: pending input is discarded before the key is read. + +The regression that made this necessary. `read-char-choice' reads the input +queue, so a key typed before the prompt appeared would answer it: a queued y +would confirm a shutdown or a file deletion instantly. The typed-\"yes\" +form absorbed such a key harmlessly, so dropping it without this guard would +have traded a rare annoyance for a rare catastrophe. + +Asserted on ordering, since that is the whole property: the discard has to +happen before the read, not merely somewhere in the function." + (let ((events '())) + (cl-letf (((symbol-function 'discard-input) + (lambda (&rest _) (push 'discard events) nil)) + ((symbol-function 'read-char-choice) + (lambda (&rest _) (push 'read events) ?y))) + (should (eq (cj/confirm-destructive "Really? ") t))) + (should (equal (nreverse events) '(discard read))))) + +;;; Error Cases + +(ert-deftest test-system-lib-confirm-destructive-declines-on-other-char () + "Error: anything that is not y or n declines rather than confirming. + +`read-char-choice' normally loops until it gets a listed character, but it +can return outside the set -- `read-char-from-minibuffer' yields RET when the +minibuffer result is empty. On an irreversible action the safe reading of an +unexpected answer is no." + (dolist (ch (list ?\r ?\n ?\s ?q ?\C-m)) + (cl-letf (((symbol-function 'read-char-choice) (lambda (&rest _) ch))) + (should-not (cj/confirm-destructive "Really? "))))) + +(ert-deftest test-system-lib-confirm-destructive-propagates-quit () + "Error: C-g aborts the caller rather than reading as a confirmation. +Swallowing the quit here would turn an abort into a yes on an irreversible +action." + (cl-letf (((symbol-function 'read-char-choice) + (lambda (&rest _) (signal 'quit nil)))) + ;; `should-error' cannot express this: quit is not an error, so ERT lets + ;; it through and reports the test as QUIT rather than passed. Catching + ;; it here is what makes the assertion a real pass or fail. + (should (eq 'quit (condition-case nil + (progn (cj/confirm-destructive "Really? ") + 'returned-normally) + (quit 'quit)))))) + +(ert-deftest test-system-lib-confirm-destructive-prompt-shows-choices () + "Error: the prompt names the keys that answer, so an unfamiliar prompt is +not a guessing game." + (let (prompt) + (cl-letf (((symbol-function 'read-char-choice) + (lambda (p &rest _) (setq prompt p) ?n))) + (cj/confirm-destructive "Delete everything? ")) + (should (string-match-p "Delete everything\\?" prompt)) + (should (string-match-p "y or n" prompt)))) + +(provide 'test-system-lib-confirm-destructive) +;;; test-system-lib-confirm-destructive.el ends here diff --git a/tests/test-system-lib-confirm-strong.el b/tests/test-system-lib-confirm-strong.el deleted file mode 100644 index 26c00822..00000000 --- a/tests/test-system-lib-confirm-strong.el +++ /dev/null @@ -1,37 +0,0 @@ -;;; test-system-lib-confirm-strong.el --- Tests for cj/confirm-strong -*- lexical-binding: t; -*- - -;;; Commentary: -;; ERT tests for `cj/confirm-strong', the typed-"yes" confirmation used for -;; irreversible actions. The behavior under test is the long-form guarantee: -;; the prompt demands a typed yes/no even when the global single-key default -;; (`use-short-answers') is in effect. - -;;; Code: - -(require 'ert) -(require 'cl-lib) -(require 'system-lib) - -(ert-deftest test-system-lib-confirm-strong-returns-t-on-yes () - "Normal: passes a t answer through from `yes-or-no-p'." - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t))) - (should (eq (cj/confirm-strong "Really? ") t)))) - -(ert-deftest test-system-lib-confirm-strong-returns-nil-on-no () - "Normal: passes a nil answer through from `yes-or-no-p'." - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) nil))) - (should (eq (cj/confirm-strong "Really? ") nil)))) - -(ert-deftest test-system-lib-confirm-strong-forces-long-form () - "Boundary: binds `use-short-answers' to nil for the call even when it is -globally t, so the irreversible prompt requires a typed yes/no regardless of -the single-key default." - (let ((use-short-answers t) - (seen 'unset)) - (cl-letf (((symbol-function 'yes-or-no-p) - (lambda (&rest _) (setq seen use-short-answers) t))) - (cj/confirm-strong "Really? ") - (should (eq seen nil))))) - -(provide 'test-system-lib-confirm-strong) -;;; test-system-lib-confirm-strong.el ends here diff --git a/tests/test-telega-config--docker-pin.el b/tests/test-telega-config--docker-pin.el index 894dbfdd..8f5b62bd 100644 --- a/tests/test-telega-config--docker-pin.el +++ b/tests/test-telega-config--docker-pin.el @@ -5,9 +5,15 @@ ;; ;; telega infers its image from `telega-tdlib-min-version' and only pins to a ;; version tag when min and max versions are equal and the version ends in -;; ".0". This config has min "1.8.64" and max nil, so the inference always +;; ".0". This config has min "1.8.66" and max nil, so the inference always ;; falls through to "zevlg/telega-server:latest" -- a moving tag that can ;; swap the server out from under a fixed elisp version without notice. +;; +;; Since 2026-08-25 the pin names an image built locally from +;; docker/telega-server/Dockerfile (upstream's image is missing a shared +;; library, zevlg/telega.el#596). Three files have to agree on that image: +;; the defcustom default, the Makefile's build tag, and the Dockerfile's +;; digest-pinned base. The tests below hold them together. ;;; Code: @@ -17,6 +23,18 @@ (add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) (require 'telega-config) +(defun test-telega-config--file-string (relative) + "Return the contents of RELATIVE under `user-emacs-directory'." + (with-temp-buffer + (insert-file-contents (expand-file-name relative user-emacs-directory)) + (buffer-string))) + +(defun test-telega-config--pin-default () + "Return the defcustom's shipped default, not the live value. +Customizing the pin (including to nil) is not a test failure; only +changing the shipped default is." + (eval (car (get 'cj/telega-docker-image 'standard-value)) t)) + ;; -- cj/--telega-docker-pinned-image ----------------------------------------- (ert-deftest test-telega-config-pin-returns-configured-reference () @@ -77,17 +95,118 @@ name, so this stays a reversible setting." "Normal: the advice is a named function so it can be removed by reference." (should (fboundp 'cj/--telega-docker-image-name))) -(ert-deftest test-telega-config-pin-default-is-a-digest-reference () - "Normal: the shipped default pins by digest, not by a floating tag. -A tag pin (:latest, or even a version tag upstream can re-push) still -moves; a digest names one immutable image. - -Reads the defcustom's standard value rather than the live variable, so -customizing the pin (including to nil, handing the choice back to telega) -is not a test failure -- only changing the shipped default is." - (let ((default (eval (car (get 'cj/telega-docker-image 'standard-value)) t))) +;; -- the shipped default and the files it depends on ------------------------- + +(ert-deftest test-telega-config-pin-default-matches-makefile-build-tag () + "Normal: the default pin is exactly the tag `make telega-image' builds. +The image is built locally, so the pin is a tag rather than a registry +digest. The Makefile owns the tag; the defcustom must name the same one +or a fresh machine builds an image telega never looks for." + (let ((makefile (test-telega-config--file-string "Makefile"))) + (should (string-match "^TELEGA_IMAGE[ \t]*[?:]?=[ \t]*\\([^ \t\n]+\\)" makefile)) + (should (equal (test-telega-config--pin-default) + (match-string 1 makefile))))) + +(ert-deftest test-telega-config-pin-default-is-a-local-tag-not-a-digest () + "Boundary: the default is a plain tag, with no registry digest suffix. +A locally built image has no RepoDigest, so a digest reference here could +never resolve." + (let ((default (test-telega-config--pin-default))) (should (stringp default)) - (should (string-match-p "@sha256:[0-9a-f]\\{64\\}\\'" default)))) + (should (string-match-p "\\`[a-z0-9./-]+:[A-Za-z0-9._-]+\\'" default)) + (should-not (string-match-p "@sha256:" default)))) + +(ert-deftest test-telega-config-dockerfile-pins-base-image-by-digest () + "Normal: the Dockerfile's base is an immutable upstream digest. +This is where the digest guarantee the old pin gave now lives. A tag in +the FROM line would let upstream swap the base under a rebuild." + (let ((dockerfile (test-telega-config--file-string "docker/telega-server/Dockerfile"))) + (should (string-match-p + "^FROM zevlg/telega-server@sha256:[0-9a-f]\\{64\\}[ \t]*$" + dockerfile)))) + +(ert-deftest test-telega-config-dockerfile-adds-the-missing-library () + "Normal: the Dockerfile installs libglycin, the whole reason it exists. +Upstream's image fails to start without it (zevlg/telega.el#596)." + (let ((dockerfile (test-telega-config--file-string "docker/telega-server/Dockerfile"))) + (should (string-match-p "^RUN apk add .*libglycin" dockerfile)))) + +;; -- cj/--telega-docker-image-present-p (the docker boundary) ---------------- +;; Exercised against a fake `docker' executable on a private exec-path rather +;; than by mocking `call-process' (a subr; see the native-comp mocking gotcha). + +(defun test-telega-config--with-fake-docker (exit-code thunk) + "Call THUNK with a fake `docker' on `exec-path' that exits EXIT-CODE." + (let* ((dir (make-temp-file "fake-docker-" t)) + (script (expand-file-name "docker" dir))) + (unwind-protect + (progn + (with-temp-file script + (insert (format "#!/bin/sh\nexit %d\n" exit-code))) + (set-file-modes script #o700) + (let ((exec-path (list dir))) + (funcall thunk))) + (delete-directory dir t)))) + +(ert-deftest test-telega-config-image-present-p-true-when-inspect-succeeds () + "Normal: `docker image inspect' exiting 0 means the image is present." + (test-telega-config--with-fake-docker 0 + (lambda () (should (cj/--telega-docker-image-present-p "cj/telega-server:x"))))) + +(ert-deftest test-telega-config-image-present-p-nil-when-inspect-fails () + "Boundary: a non-zero exit (no such image) reads as not present." + (test-telega-config--with-fake-docker 1 + (lambda () (should-not (cj/--telega-docker-image-present-p "cj/telega-server:x"))))) + +(ert-deftest test-telega-config-image-present-p-nil-without-docker () + "Error: with no docker on `exec-path', the helper returns nil instead of +signalling, so the launcher can still route the user to the make target." + (let ((exec-path nil)) + (should-not (cj/--telega-docker-image-present-p "cj/telega-server:x")))) + +;; -- cj/telega refuses to launch against a missing local image --------------- + +(ert-deftest test-telega-config-missing-image-message-names-image-and-target () + "Normal: the message names the missing image and the make target that builds it." + (let ((msg (cj/--telega-missing-image-message "cj/telega-server:x"))) + (should (string-match-p "cj/telega-server:x" msg)) + (should (string-match-p "make telega-image" msg)))) + +(ert-deftest test-telega-config-launcher-errors-when-pinned-image-is-absent () + "Error: with a pin set and no such image, `cj/telega' stops with the make hint. +Without this, docker fails to pull a local-only tag and the error names a +registry the image was never meant to come from." + (let ((cj/telega-docker-image "cj/telega-server:x") + (launched nil)) + (cl-letf (((symbol-function 'locate-library) (lambda (&rest _) "telega.el")) + ((symbol-function 'cj/--telega-docker-image-present-p) (lambda (_) nil)) + ((symbol-function 'telega) (lambda (&rest _) (setq launched t)))) + (let ((err (should-error (cj/telega) :type 'user-error))) + (should (string-match-p "make telega-image" (cadr err)))) + (should-not launched)))) + +(ert-deftest test-telega-config-launcher-runs-when-pinned-image-is-present () + "Normal: with the pinned image present, `cj/telega' launches telega." + (let ((cj/telega-docker-image "cj/telega-server:x") + (launched nil)) + (cl-letf (((symbol-function 'locate-library) (lambda (&rest _) "telega.el")) + ((symbol-function 'cj/--telega-docker-image-present-p) (lambda (_) t)) + ((symbol-function 'telega) (lambda (&rest _) (setq launched t)))) + (cj/telega) + (should launched)))) + +(ert-deftest test-telega-config-launcher-skips-image-check-without-a-pin () + "Boundary: with no pin, telega infers and pulls its own image; no check runs." + (let ((cj/telega-docker-image nil) + (checked nil) + (launched nil)) + (cl-letf (((symbol-function 'locate-library) (lambda (&rest _) "telega.el")) + ((symbol-function 'cj/--telega-docker-image-present-p) + (lambda (_) (setq checked t) nil)) + ((symbol-function 'telega) (lambda (&rest _) (setq launched t)))) + (cj/telega) + (should-not checked) + (should launched)))) (provide 'test-telega-config--docker-pin) ;;; test-telega-config--docker-pin.el ends here diff --git a/tests/test-telega-config.el b/tests/test-telega-config.el index d8aaeb4d..54a601c9 100644 --- a/tests/test-telega-config.el +++ b/tests/test-telega-config.el @@ -45,6 +45,10 @@ stub's cryptic load-file failure." (let (called) (cl-letf (((symbol-function 'featurep) (lambda (sym &optional _sub) (eq sym 'telega))) + ;; The pinned image is a local build; treat it as present so + ;; this test stays about delegation, not the image check. + ((symbol-function 'cj/--telega-docker-image-present-p) + (lambda (_) t)) ((symbol-function 'telega) (lambda (&rest _) (setq called t)))) (cj/telega)) diff --git a/tests/test-term-tmux-detach.el b/tests/test-term-tmux-detach.el new file mode 100644 index 00000000..9bd94776 --- /dev/null +++ b/tests/test-term-tmux-detach.el @@ -0,0 +1,62 @@ +;;; test-term-tmux-detach.el --- Tests for cj/term-tmux-detach -*- lexical-binding: t; -*- + +;;; Commentary: +;; A keyboard C-b inside the Claude Code pane does not reach tmux as a prefix +;; (it lands as stray text), so detaching needs the same pty string path +;; `cj/term-copy-mode-dwim' uses for C-b [. These tests pin that path and +;; the no-tmux fallback. + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'package) + +;; Same shape as test-term-tmux-history.el: `make test' runs with no +;; package-initialize, so eat has to be made loadable here before eat-config. +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(add-to-list 'load-path (expand-file-name "tests" user-emacs-directory)) +(setq load-prefer-newer t) +(require 'eat) +(require 'eat-config) + +(ert-deftest test-eat-config-tmux-detach-sends-prefix-and-d-when-attached () + "Normal: with tmux attached, the command writes C-b d into the pty, nothing else." + (let ((sent nil)) + (cl-letf (((symbol-function 'cj/term--in-tmux-p) (lambda () t)) + ((symbol-function 'cj/--term-send-string) (lambda (s) (push s sent)))) + (cj/term-tmux-detach) + (should (equal sent '("\C-bd")))))) + +(ert-deftest test-eat-config-tmux-detach-does-nothing-without-tmux () + "Boundary: with no tmux client, nothing is written and the user is told why. +Writing C-b d into a plain shell would type a control character into it." + (let ((sent nil) + (told nil)) + (cl-letf (((symbol-function 'cj/term--in-tmux-p) (lambda () nil)) + ((symbol-function 'cj/--term-send-string) (lambda (s) (push s sent))) + ((symbol-function 'message) (lambda (fmt &rest args) + (setq told (apply #'format fmt args))))) + (cj/term-tmux-detach) + (should-not sent) + (should (string-match-p "tmux" told))))) + +(ert-deftest test-eat-config-tmux-detach-survives-dead-process () + "Error: with tmux reported attached but no live pty, the command returns +without signalling. `cj/--term-send-string' already guards on +`process-live-p'; this pins that the detach path relies on it rather than +calling `process-send-string' directly." + (with-temp-buffer + (cl-letf (((symbol-function 'cj/term--in-tmux-p) (lambda () t))) + (should-not (condition-case err + (progn (cj/term-tmux-detach) nil) + (error err)))))) + +(ert-deftest test-eat-config-tmux-detach-bound-on-term-map () + "Normal: the command sits on the terminal map next to copy-mode (\"c\")." + (should (eq (keymap-lookup cj/term-map "d") #'cj/term-tmux-detach))) + +(provide 'test-term-tmux-detach) +;;; test-term-tmux-detach.el ends here diff --git a/tests/test-undead-buffers--native-comp-log-undead.el b/tests/test-undead-buffers--native-comp-log-undead.el new file mode 100644 index 00000000..dee9a134 --- /dev/null +++ b/tests/test-undead-buffers--native-comp-log-undead.el @@ -0,0 +1,92 @@ +;;; test-undead-buffers--native-comp-log-undead.el --- the native-comp log survives the sweep -*- lexical-binding: t; -*- + +;;; Commentary: +;; Async native compilation parks every worker process on one buffer, +;; `comp-async-buffer-name' (*Async-native-compile-log*), and the worker's +;; sentinel reads that buffer back before it starts the next job. Killing +;; the buffer sends SIGHUP to every worker under it (they are :noquery, so +;; nothing asks), each sentinel then dies in `with-current-buffer' on the +;; dead buffer, and `comp--run-async-workers' is never called again: the +;; queue is stranded for the life of the daemon and nothing is ever cached. +;; +;; `cj/dashboard-only' on `emacs-startup-hook' runs +;; `cj/kill-all-other-buffers-and-windows', which is exactly such a sweep, +;; and in a real daemon `dashboard-insert-startupify-lists' has already +;; created *dashboard* on `after-init-hook', so the sweep branch is the one +;; that runs. These tests pin the log buffer to the undead list so the +;; sweep buries it and the workers live. The fixture puts a live :noquery +;; process on the buffer, because that is the state the bug needs; a plain +;; buffer would survive a kill-and-recreate just the same. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'undead-buffers) + +(defconst test-undead--comp-log "*Async-native-compile-log*") + +(defun test-undead--make-sleeper (buffer) + "Start a quiet, long-lived process attached to BUFFER and return it." + (make-process :name "test-undead-sleeper" :buffer buffer + :command '("sleep" "30") :noquery t)) + +(defun test-undead--settle () + "Let any signal the sweep sent land before liveness is observed." + (let ((deadline (+ (float-time) 0.3))) + (while (< (float-time) deadline) + (accept-process-output nil 0.05)))) + +;;; Normal Cases + +(ert-deftest test-undead-buffers-native-comp-log-is-undead-by-default () + "Normal: the module's default list makes the async-compile log bury-only." + (should (member test-undead--comp-log cj/undead-buffer-list)) + (should (cj/--buffer-undead-p test-undead--comp-log))) + +(ert-deftest test-undead-buffers-native-comp-log-name-matches-comp-run () + "Normal: the pinned name is the one comp-run actually uses. +A rename upstream would silently reopen the bug, so pin it to the variable." + (skip-unless (require 'comp-run nil t)) + (should (equal comp-async-buffer-name test-undead--comp-log))) + +(ert-deftest test-undead-buffers-native-comp-log-workers-survive-sweep () + "Normal: a worker parked on the log buffer is still running after the sweep. +The positive control is an ordinary process buffer, which the sweep kills +out from under its process -- that is what happened to the workers without +the undead entry. The control's process is not asserted dead: killing the +buffer sends SIGHUP, and a launching shell that ignores SIGHUP (nohup) hands +that disposition down, so its death is not deterministic across harnesses." + (skip-unless (executable-find "sleep")) + (delete-other-windows) + (let* ((main (current-buffer)) + (existing (get-buffer test-undead--comp-log)) + (log (or existing (get-buffer-create test-undead--comp-log))) + (victim (generate-new-buffer "*test-sweep-victim*")) + (worker (test-undead--make-sleeper log)) + (control (test-undead--make-sleeper victim))) + (unwind-protect + (progn + (cj/kill-all-other-buffers-and-windows) + (test-undead--settle) + (should (buffer-live-p main)) + (should (buffer-live-p log)) + (should (process-live-p worker)) + (should-not (buffer-live-p victim))) + (when (process-live-p worker) (delete-process worker)) + (when (process-live-p control) (delete-process control)) + (when (buffer-live-p victim) (kill-buffer victim)) + ;; Only remove what this test created. `kill-buffer' the function is + ;; not the remapped command, so the undead list doesn't apply. + (when (and (not existing) (buffer-live-p log)) (kill-buffer log)) + (delete-other-windows)))) + +;;; Boundary Cases + +(ert-deftest test-undead-buffers-native-comp-log-match-is-exact () + "Boundary: only the exact name is undead; a uniquified copy is not." + (should-not (cj/--buffer-undead-p "*Async-native-compile-log*<2>")) + (should-not (cj/--buffer-undead-p " *Async-native-compile-log*"))) + +(provide 'test-undead-buffers--native-comp-log-undead) +;;; test-undead-buffers--native-comp-log-undead.el ends here diff --git a/tests/test-undead-buffers--warnings-undead.el b/tests/test-undead-buffers--warnings-undead.el new file mode 100644 index 00000000..858dbf76 --- /dev/null +++ b/tests/test-undead-buffers--warnings-undead.el @@ -0,0 +1,63 @@ +;;; test-undead-buffers--warnings-undead.el --- *Warnings* survives the buffer sweep -*- lexical-binding: t; -*- + +;;; Commentary: +;; Emacs 31.1's warnings.el defers daemon-startup warnings into a one-shot +;; `after-make-frame-functions' closure that holds the *Warnings* buffer +;; object and displays it on the first client frame. Killing that buffer +;; during startup leaves the closure holding a dead buffer, `display-buffer' +;; then signals inside `make-frame', server.el reports the window system as +;; unsupported, and emacsclient silently retries on $DISPLAY -- the first +;; frame of the session lands on XWayland instead of Wayland. +;; +;; `cj/dashboard-only' on `emacs-startup-hook' runs +;; `cj/kill-all-other-buffers-and-windows', which is exactly such a sweep. +;; These tests pin *Warnings* to the undead list so the sweep buries it +;; instead of killing it. Error-path coverage of the predicate itself (a nil +;; or non-string name) lives in test-undead-buffers--buffer-undead-p.el. + +;;; Code: + +(require 'ert) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'undead-buffers) + +;;; Normal Cases + +(ert-deftest test-undead-buffers-warnings-is-undead-by-default () + "Normal: the module's default list makes *Warnings* bury-only." + (should (member "*Warnings*" cj/undead-buffer-list)) + (should (cj/--buffer-undead-p "*Warnings*"))) + +(ert-deftest test-undead-buffers-warnings-survives-kill-all-other-buffers () + "Normal: the startup sweep buries *Warnings* rather than killing it. +This is the sweep `cj/dashboard-only' runs from `emacs-startup-hook'." + (delete-other-windows) + (unwind-protect + (let* ((main (current-buffer)) + (existing (get-buffer "*Warnings*")) + (warnings (or existing (get-buffer-create "*Warnings*"))) + (victim (generate-new-buffer "*test-sweep-victim*"))) + (unwind-protect + (progn + (cj/kill-all-other-buffers-and-windows) + (should (buffer-live-p main)) + (should (buffer-live-p warnings)) + (should-not (buffer-live-p victim))) + (when (buffer-live-p victim) (kill-buffer victim)) + ;; Only remove what this test created. `kill-buffer' the function + ;; is not the remapped command, so the undead list doesn't apply. + (when (and (not existing) (buffer-live-p warnings)) + (kill-buffer warnings)))) + (delete-other-windows))) + +;;; Boundary Cases + +(ert-deftest test-undead-buffers-warnings-match-is-exact () + "Boundary: only the exact name is undead; a uniquified *Warnings*<2> is not. +The list matches exact names, so a second warnings buffer made by +`generate-new-buffer' is an ordinary buffer to the sweep." + (should-not (cj/--buffer-undead-p "*Warnings*<2>")) + (should-not (cj/--buffer-undead-p " *Warnings*"))) + +(provide 'test-undead-buffers--warnings-undead) +;;; test-undead-buffers--warnings-undead.el ends here diff --git a/tests/test-video-audio-recording--keybindings.el b/tests/test-video-audio-recording--keybindings.el new file mode 100644 index 00000000..cdb6493a --- /dev/null +++ b/tests/test-video-audio-recording--keybindings.el @@ -0,0 +1,130 @@ +;;; test-video-audio-recording--keybindings.el --- recording toggle keybinding placement -*- lexical-binding: t; -*- + +;;; Commentary: +;; The two recording toggles get a fast chord alongside the C-; r prefix: F9 +;; starts/stops video, S-F9 starts/stops audio. +;; +;; Reaching them from inside an EAT buffer turns on which key categories each +;; input mode claims. Semi-char mode -- the default, and where agent buffers +;; sit -- is built from (:ascii :arrow :navigation) and never claims function +;; keys, so F9 already fell through to the global map there. Char mode adds +;; :function, binding f1 through f63 to `eat-self-input', and it is a minor +;; mode, so its map outranks `eat-mode-map'. The char-mode entries are the +;; load-bearing ones; the semi-char entry is belt-and-braces. +;; +;; :function claims only the unmodified keys, which is why getting this wrong +;; split the pair rather than breaking it outright: S-F9 toggled audio in a +;; char-mode buffer while F9 went to the program under the cursor. +;; +;; These tests require eat first so the module's `with-eval-after-load' fires. +;; The char-mode cases resolve through `key-binding' in a fixture that +;; reproduces minor-mode precedence, because reading a binding back out of the +;; map the module just wrote proves nothing about which map wins on a keypress. + +;;; Code: + +(require 'ert) +(require 'package) + +(setq package-user-dir (expand-file-name "elpa" user-emacs-directory)) +(package-initialize) +(add-to-list 'load-path (expand-file-name "modules" user-emacs-directory)) +(require 'eat) +(require 'video-audio-recording) + +;;; Normal + +(ert-deftest test-video-audio-recording-f9-bound-globally () + "Normal: F9 toggles video recording, S-F9 toggles audio recording." + (should (eq (lookup-key (current-global-map) (kbd "<f9>")) + #'cj/video-recording-toggle)) + (should (eq (lookup-key (current-global-map) (kbd "S-<f9>")) + #'cj/audio-recording-toggle))) + +(ert-deftest test-video-audio-recording-f9-bound-in-eat-semi-char-mode-map () + "Normal: both chords are bound in `eat-semi-char-mode-map'. +Redundant rather than load-bearing: semi-char is built without :function, so a +function key already falls through to the global map. Asserted anyway so the +entry cannot be dropped silently while the comment explaining it stays." + (should (eq (keymap-lookup eat-semi-char-mode-map "<f9>") + #'cj/video-recording-toggle)) + (should (eq (keymap-lookup eat-semi-char-mode-map "S-<f9>") + #'cj/audio-recording-toggle))) + +(ert-deftest test-video-audio-recording-f9-bound-in-eat-mode-map () + "Normal: both chords are bound in `eat-mode-map', the major-mode map every +EAT buffer carries regardless of input mode." + (should (eq (keymap-lookup eat-mode-map "<f9>") + #'cj/video-recording-toggle)) + (should (eq (keymap-lookup eat-mode-map "S-<f9>") + #'cj/audio-recording-toggle))) + +(ert-deftest test-video-audio-recording-f9-bound-in-eat-char-mode-maps () + "Normal: both chords are bound in the two char-mode maps. +Char mode is built with EAT's :function category, which binds f1 through f63 +to `eat-self-input'. These entries are what override that." + (dolist (map (list eat-char-mode-map eat-eshell-char-mode-map)) + (should (eq (keymap-lookup map "<f9>") #'cj/video-recording-toggle)) + (should (eq (keymap-lookup map "S-<f9>") #'cj/audio-recording-toggle)))) + +;;; Boundary + +(ert-deftest test-video-audio-recording-f9-chords-are-distinct () + "Boundary: the shifted and unshifted chords resolve to different commands. +A copy-paste binding both to the same toggle would satisfy every +binding-is-present assertion above, so assert the difference directly." + (should-not (eq (lookup-key (current-global-map) (kbd "<f9>")) + (lookup-key (current-global-map) (kbd "S-<f9>"))))) + +(defun test-video-audio-recording--in-char-mode (body) + "Run BODY in a buffer wired the way a live EAT char-mode buffer is. +`eat--char-mode' is a minor mode, so its map is consulted ahead of the +major-mode map. Reproducing that ordering is the point: reading a binding +back out of the map the module just wrote proves nothing about which map wins +when a key is actually pressed." + (with-temp-buffer + (use-local-map eat-mode-map) + (let ((minor-mode-overriding-map-alist + (list (cons 'eat--char-mode eat-char-mode-map))) + (eat--char-mode t)) + (funcall body)))) + +(ert-deftest test-video-audio-recording-f9-resolves-in-char-mode () + "Boundary: both chords resolve to the toggles through the real precedence +chain in a char-mode buffer. Before this override F9 resolved to +`eat-self-input' and went to the program under the cursor, while S-F9 reached +Emacs — so the pair silently split, audio recording and video not." + (test-video-audio-recording--in-char-mode + (lambda () + (should (eq (key-binding (kbd "<f9>")) #'cj/video-recording-toggle)) + (should (eq (key-binding (kbd "S-<f9>")) #'cj/audio-recording-toggle))))) + +;;; Error + +(ert-deftest test-video-audio-recording-char-mode-fixture-really-is-char-mode () + "Error (positive control): the char-mode fixture genuinely puts EAT's map in +front. F8 sits in the same :function category as F9 and this module never +touches it, so it must still reach `eat-self-input'. If it resolves anywhere +else the fixture is inert, and the resolution test above would pass without +ever consulting `eat-char-mode-map' — which is precisely how the first cut of +this file missed that F9 was being swallowed there." + (test-video-audio-recording--in-char-mode + (lambda () + (should (eq (key-binding (kbd "<f8>")) #'eat-self-input))))) + +(ert-deftest test-video-audio-recording-f9-targets-are-commands () + "Error: a key bound to a non-interactive function fails at press time with a +`commandp' error rather than at load, so assert both targets are real commands." + (should (commandp (lookup-key (current-global-map) (kbd "<f9>")))) + (should (commandp (lookup-key (current-global-map) (kbd "S-<f9>"))))) + +(ert-deftest test-video-audio-recording-prefix-bindings-still-reachable () + "Error/regression (positive control): the fast chords must not disturb the +C-; r prefix path. Without this, deleting the prefix map outright would leave +every assertion above green." + (should (eq (keymap-lookup cj/record-map "v") #'cj/video-recording-toggle)) + (should (eq (keymap-lookup cj/record-map "a") #'cj/audio-recording-toggle)) + (should (eq (keymap-lookup cj/custom-keymap "r") cj/record-map))) + +(provide 'test-video-audio-recording--keybindings) +;;; test-video-audio-recording--keybindings.el ends here 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)) |