diff options
Diffstat (limited to 'tests')
43 files changed, 5585 insertions, 0 deletions
diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 index 0000000..a6b6812 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,295 @@ +# Makefile for pearl.el test suite +# Usage: +# make test - Run all tests (excluding :slow tagged) +# make test-all - Run every test, including :slow tagged +# make test-file FILE=mapping - Run tests in one file +# make test-one TEST=name - Run one specific test +# make test-unit - Run unit tests only +# make test-integration - Run integration tests only +# make clean - Remove byte-compiled files + +# Configuration +EASK ?= eask + +# eask treats the CWD as its workspace and reads .eask/ from there. All +# eask invocations must run from project root so the project's .eask/ +# is picked up. The (cd "tests/") --eval restores Emacs default-directory +# so test files' relative paths (../pearl.el, test-bootstrap.el) +# resolve correctly. +PROJECT_ROOT := $(abspath ..) +EMACS_BATCH = cd $(PROJECT_ROOT) && $(EASK) emacs --batch --eval '(cd "tests/")' + +# Include local overrides if present (per-machine knobs, not committed) +-include makefile-local + +# Test files +ALL_TESTS = $(filter-out test-bootstrap.el,$(wildcard test-*.el)) +UNIT_TESTS = $(filter-out test-integration-%.el,$(ALL_TESTS)) +INTEGRATION_TESTS = $(wildcard test-integration-*.el) + +# ERT selector that excludes tests tagged :slow. Applied to default +# test runs so a slow integration suite doesn't dominate the fast +# feedback path. test-all runs everything; test-one and test-name +# honor the user-supplied pattern verbatim. +ERT_FAST_SELECTOR = (ert-run-tests-batch-and-exit '(not (tag :slow))) + +# Colors for output (if terminal supports it) +RED = \033[0;31m +GREEN = \033[0;32m +YELLOW = \033[1;33m +NC = \033[0m + +.PHONY: all test test-all test-file test-one test-name test-unit test-integration validate lint clean help check-deps count list + +all: test + +# Verify eask + installed deps are available +check-deps: + @if ! command -v $(EASK) >/dev/null 2>&1; then \ + printf "$(RED)Error: eask not found on PATH$(NC)\n"; \ + echo "Install: npm install -g @emacs-eask/cli"; \ + echo " or: https://emacs-eask.github.io/Getting-Started/Install-Eask/"; \ + exit 1; \ + fi + @if [ ! -d $(PROJECT_ROOT)/.eask ]; then \ + printf "$(YELLOW)Warning: .eask not found — run 'make setup' from project root$(NC)\n"; \ + exit 1; \ + fi + @$(EMACS_BATCH) -l check-deps.el >$(PROJECT_ROOT)/tests/check-deps-output.log 2>&1 || { \ + printf "$(RED)Error: required Emacs Lisp test dependencies are missing$(NC)\n"; \ + cat $(PROJECT_ROOT)/tests/check-deps-output.log; \ + exit 1; \ + } + @printf "$(GREEN)✓ eask available, required Emacs Lisp deps loadable$(NC)\n" + +# Run all tests (excluding :slow) +test: check-deps + @printf "$(YELLOW)Running all tests ($(words $(ALL_TESTS)) files, excluding :slow)...$(NC)\n" + @$(MAKE) --no-print-directory test-unit + @$(MAKE) --no-print-directory test-integration + @printf "$(GREEN)[✓] All tests complete$(NC)\n" + +# Run every test, including :slow tagged +test-all: check-deps + @printf "$(YELLOW)Running all tests including :slow ($(words $(ALL_TESTS)) files)...$(NC)\n" + @failed=0; \ + for testfile in $(ALL_TESTS); do \ + echo " Testing $$testfile..."; \ + $(EMACS_BATCH) -l ert -l "$$testfile" \ + --eval '(ert-run-tests-batch-and-exit t)' || failed=$$((failed + 1)); \ + done; \ + if [ $$failed -eq 0 ]; then \ + printf "$(GREEN)[✓] All tests passed$(NC)\n"; \ + else \ + printf "$(RED)[✗] $$failed test file(s) failed$(NC)\n"; \ + exit 1; \ + fi + +# Run tests in one file +test-file: check-deps +ifndef FILE + @printf "$(RED)Error: FILE not specified$(NC)\n" + @echo "Usage: make test-file FILE=mapping" + @echo " make test-file FILE=test-pearl-mapping.el" + @exit 1 +endif + @TESTFILE=$$(find . -maxdepth 1 -name "*$(FILE)*.el" -type f | head -1 | sed 's|^\./||'); \ + if [ -z "$$TESTFILE" ]; then \ + printf "$(RED)Error: No test file matching '$(FILE)' found$(NC)\n"; \ + exit 1; \ + fi; \ + printf "$(YELLOW)Running tests in $$TESTFILE...$(NC)\n"; \ + $(EMACS_BATCH) -l ert -l "$$TESTFILE" \ + --eval "$(ERT_FAST_SELECTOR)" 2>&1 | tee $(PROJECT_ROOT)/tests/test-file-output.log; \ + if [ $$? -eq 0 ]; then \ + printf "$(GREEN)✓ All tests in $$TESTFILE passed!$(NC)\n"; \ + else \ + printf "$(RED)✗ Some tests failed.$(NC)\n"; \ + exit 1; \ + fi + +# Run one specific test (fuzzy match by name) +test-one: check-deps +ifndef TEST + @printf "$(RED)Error: TEST not specified$(NC)\n" + @echo "Usage: make test-one TEST=priority" + @echo " make test-one TEST=test-pearl-map-priority-urgent" + @exit 1 +endif + @printf "$(YELLOW)Searching for test matching '$(TEST)'...$(NC)\n" + @TESTFILE=$$(grep -l "ert-deftest.*$(TEST)" test-*.el 2>/dev/null | head -1); \ + if [ -z "$$TESTFILE" ]; then \ + printf "$(RED)Error: No test matching '$(TEST)' found$(NC)\n"; \ + exit 1; \ + fi; \ + TESTNAME=$$(grep "ert-deftest.*$(TEST)" "$$TESTFILE" | sed 's/^(ert-deftest \([^ ]*\).*/\1/' | head -1); \ + printf "$(YELLOW)Running test '$$TESTNAME' in $$TESTFILE...$(NC)\n"; \ + $(EMACS_BATCH) -l ert -l "$$TESTFILE" \ + --eval "(ert-run-tests-batch-and-exit \"$$TESTNAME\")" 2>&1; \ + if [ $$? -eq 0 ]; then \ + printf "$(GREEN)✓ Test $$TESTNAME passed!$(NC)\n"; \ + else \ + printf "$(RED)✗ Test $$TESTNAME failed.$(NC)\n"; \ + exit 1; \ + fi + +# Run only unit tests (excluding :slow) +test-unit: check-deps + @printf "$(YELLOW)Running unit tests ($(words $(UNIT_TESTS)) files, excluding :slow)...$(NC)\n" + @failed=0; \ + for testfile in $(UNIT_TESTS); do \ + echo " Testing $$testfile..."; \ + $(EMACS_BATCH) -l ert -l "$$testfile" \ + --eval "$(ERT_FAST_SELECTOR)" || failed=$$((failed + 1)); \ + done; \ + if [ $$failed -eq 0 ]; then \ + printf "$(GREEN)[✓] All unit tests passed$(NC)\n"; \ + else \ + printf "$(RED)[✗] $$failed unit test file(s) failed$(NC)\n"; \ + exit 1; \ + fi + +# Run only integration tests (excluding :slow) +test-integration: check-deps + @printf "$(YELLOW)Running integration tests ($(words $(INTEGRATION_TESTS)) files, excluding :slow)...$(NC)\n" + @if [ -z "$(INTEGRATION_TESTS)" ]; then \ + printf "$(YELLOW) (no integration test files yet)$(NC)\n"; \ + fi + @failed=0; \ + for testfile in $(INTEGRATION_TESTS); do \ + echo " Testing $$testfile..."; \ + $(EMACS_BATCH) -l ert -l "$$testfile" \ + --eval "$(ERT_FAST_SELECTOR)" || failed=$$((failed + 1)); \ + done; \ + if [ $$failed -eq 0 ]; then \ + printf "$(GREEN)[✓] All integration tests passed$(NC)\n"; \ + else \ + printf "$(RED)[✗] $$failed integration test file(s) failed$(NC)\n"; \ + exit 1; \ + fi + +# Run tests matching a name pattern (ERT selector) +test-name: check-deps +ifndef TEST + @printf "$(RED)Error: TEST not specified$(NC)\n" + @echo "Usage: make test-name TEST=test-pearl-map" + @echo " make test-name TEST='test-pearl-map-*'" + @exit 1 +endif + @printf "$(YELLOW)Running tests matching pattern: $(TEST)...$(NC)\n" + @$(EMACS_BATCH) -l ert \ + --eval "(dolist (f (directory-files \".\" t \"^test-.*\\\\.el$$\")) (load f))" \ + --eval '(ert-run-tests-batch-and-exit "$(TEST)")' + +# Count tests +count: + @echo "Test file inventory:" + @for f in $(ALL_TESTS); do \ + count=$$(grep -c "^(ert-deftest" "$$f" 2>/dev/null || echo 0); \ + printf "%3d tests - %s\n" "$$count" "$$f"; \ + done | sort -rn + @total=$$(find . -name "test-*.el" -exec grep -c "^(ert-deftest" {} \; | awk '{sum+=$$1} END {print sum}'); \ + printf "$(GREEN)Total: $$total tests across $(words $(ALL_TESTS)) files$(NC)\n" + +# List all available tests +list: + @echo "Available tests:" + @grep -h "^(ert-deftest" test-*.el | sed 's/^(ert-deftest \([^ ]*\).*/ \1/' | sort + +# Validate Emacs Lisp syntax (parens balance — no deps needed) +validate: + @printf "$(YELLOW)Validating Emacs Lisp syntax...$(NC)\n" + @failed=0; \ + total=0; \ + for file in ../pearl.el test-*.el; do \ + if [ -f "$$file" ] && [ ! -d "$$file" ]; then \ + total=$$((total + 1)); \ + output=$$(emacs --batch -Q --eval "(progn \ + (setq byte-compile-error-on-warn nil) \ + (find-file \"$$file\") \ + (condition-case err \ + (progn \ + (check-parens) \ + (message \"✓ $$file - parentheses balanced\")) \ + (error \ + (message \"✗ $$file: %s\" (error-message-string err)) \ + (kill-emacs 1))))" 2>&1 | grep -E '(✓|✗)'); \ + if [ $$? -eq 0 ]; then \ + printf "$(GREEN)$$output$(NC)\n"; \ + else \ + printf "$(RED)$$output$(NC)\n"; \ + failed=$$((failed + 1)); \ + fi; \ + fi; \ + done; \ + if [ $$failed -eq 0 ]; then \ + printf "$(GREEN)✓ All $$total files validated successfully$(NC)\n"; \ + else \ + printf "$(RED)✗ $$failed of $$total files failed validation$(NC)\n"; \ + exit 1; \ + fi + +# Comprehensive linting with elisp-lint (via eask-installed dev dep). +# Validators disabled and why: +# - checkdoc: covered by `eask lint checkdoc' as its own MELPA-prep step. +# - package-lint: covered by `eask lint package' as its own step. +# - indent-character: project uses spaces; validator defaults to requiring tabs. +# - fill-column: validator default (70) is stricter than this project wants. +# - indent: false positives on dash threading macros (`->', `->>'). +lint: check-deps + @printf "$(YELLOW)Running elisp-lint...$(NC)\n" + @$(EMACS_BATCH) \ + -l $(PROJECT_ROOT)/pearl.el \ + --eval "(require 'elisp-lint)" \ + -f elisp-lint-files-batch \ + --no-checkdoc \ + --no-package-lint \ + --no-indent-character \ + --no-fill-column \ + --no-indent \ + $(PROJECT_ROOT)/pearl.el 2>&1; \ + if [ $$? -eq 0 ]; then \ + printf "$(GREEN)✓ Linting completed successfully$(NC)\n"; \ + else \ + printf "$(RED)✗ Linting found issues (see above)$(NC)\n"; \ + exit 1; \ + fi + +# Clean byte-compiled files +clean: + @printf "$(YELLOW)Cleaning byte-compiled files...$(NC)\n" + @rm -f *.elc ../*.elc + @rm -f check-deps-output.log test-output.log test-file-output.log test-unit-output.log test-integration-output.log + @printf "$(GREEN)✓ Cleaned$(NC)\n" + +# Show help +help: + @echo "pearl Test Suite Makefile" + @echo "" + @echo "Usage:" + @echo " make test - Run all tests, excluding :slow" + @echo " make test-all - Run all tests including :slow" + @echo " make test-unit - Run unit tests only (excluding :slow)" + @echo " make test-integration - Run integration tests only (excluding :slow)" + @echo " make test-file FILE=mapping - Run tests in one file (fuzzy match)" + @echo " make test-one TEST=priority - Run one specific test (fuzzy match)" + @echo " make test-name TEST=pattern - Run tests matching ERT name pattern" + @echo " make validate - Validate Emacs Lisp syntax (parens balance)" + @echo " make lint - Comprehensive linting with elisp-lint" + @echo " make count - Count tests per file" + @echo " make list - List all test names" + @echo " make clean - Remove byte-compiled files and logs" + @echo " make check-deps - Verify eask + loadable Emacs Lisp deps" + @echo " make help - Show this help message" + @echo "" + @echo "Project-root targets (run from project root):" + @echo " make setup - Install all deps via eask" + @echo " make compile - Byte-compile pearl.el" + @echo " make coverage - Generate simplecov JSON via undercover" + @echo "" + @echo "Tagging tests as :slow:" + @echo " (ert-deftest test-foo () :tags '(:slow) ...) — excluded by default" + @echo " Run with 'make test-all' to include them." + @echo "" + @echo "Environment variables:" + @echo " EASK - eask executable (default: eask)" diff --git a/tests/check-deps.el b/tests/check-deps.el new file mode 100644 index 0000000..12b5f60 --- /dev/null +++ b/tests/check-deps.el @@ -0,0 +1,38 @@ +;;; check-deps.el --- Verify test dependencies are loadable -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;;; Commentary: + +;; Loaded by tests/Makefile's check-deps target after eask has prepared the +;; test environment. Keep dependency discovery inside Emacs so package.el, +;; package-vc, Eask, Nix, and pre-populated load-path setups all work the same +;; way: a dependency is available if Emacs can require it. + +;;; Code: + +(when noninteractive + (package-initialize)) + +(defconst pearl-check-deps-required-features + '(request json dash s org) + "Features required by the pearl test suite.") + +(defun pearl-check-deps--missing-features () + "Return required test features that cannot be loaded." + (let (missing) + (dolist (feature pearl-check-deps-required-features (nreverse missing)) + (unless (require feature nil t) + (push feature missing))))) + +(let ((missing (pearl-check-deps--missing-features))) + (if missing + (progn + (message "Missing Emacs Lisp test dependencies: %s" + (mapconcat #'symbol-name missing ", ")) + (message "Run `make setup' from the project root, or make these features available on load-path.") + (kill-emacs 1)) + (message "Required Emacs Lisp dependencies are loadable: %s" + (mapconcat #'symbol-name pearl-check-deps-required-features ", ")))) + +;;; check-deps.el ends here diff --git a/tests/run-coverage-file.el b/tests/run-coverage-file.el new file mode 100644 index 0000000..9d5c3b3 --- /dev/null +++ b/tests/run-coverage-file.el @@ -0,0 +1,50 @@ +;;; run-coverage-file.el --- Undercover setup for per-file coverage runs -*- lexical-binding: t; -*- + +;;; Commentary: +;; Loaded by `make coverage' before each test file runs, BEFORE +;; pearl.el is loaded. Instrumenting must happen first so the +;; subsequent load picks up the instrumented source. +;; +;; Coverage data is merged across per-file invocations into a single +;; simplecov JSON at .coverage/simplecov.json (under the project root). + +;;; Code: + +(unless (require 'undercover nil t) + (message "") + (message "ERROR: undercover not installed.") + (message "Run 'make setup' to install development dependencies.") + (message "") + (kill-emacs 1)) + +;; Resolve project root from this file's location so undercover patterns +;; and the report-file path don't depend on default-directory at load time. +(defvar run-coverage--project-root + (file-name-directory + (directory-file-name + (file-name-directory (or load-file-name buffer-file-name)))) + "Absolute path to the pearl project root.") + +;; Force coverage collection in non-CI environments. Must be set after +;; loading undercover because the library's top-level form +;; `(setq undercover-force-coverage (getenv "UNDERCOVER_FORCE"))' would +;; otherwise overwrite the value. +(setq undercover-force-coverage t) + +;; Local runs emit simplecov for whatever local tooling wants it. CI sets +;; CI=true (GitHub Actions does this automatically), so we emit a coveralls +;; JSON instead and leave it on disk for the upload action to pick up. +;; The `undercover' macro splices each configuration list into `(list ,@it)', +;; which evaluates the elements. Wildcard strings have to stay atoms — using +;; `(:files ...)' form lets us evaluate `expand-file-name' to an absolute path. +(undercover (:files (expand-file-name "pearl.el" run-coverage--project-root)) + (:report-format (if (getenv "CI") 'coveralls 'simplecov)) + (:report-file (expand-file-name + (if (getenv "CI") + ".coverage/coveralls.json" + ".coverage/simplecov.json") + run-coverage--project-root)) + (:merge-report t) + (:send-report nil)) + +;;; run-coverage-file.el ends here diff --git a/tests/test-bootstrap.el b/tests/test-bootstrap.el new file mode 100644 index 0000000..85b26dd --- /dev/null +++ b/tests/test-bootstrap.el @@ -0,0 +1,47 @@ +;;; test-bootstrap.el --- Common test initialization for pearl -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Shared initialization for all pearl test files. +;; Handles package setup, dependency loading, and loading the package source. +;; +;; Usage: (require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +;;; Code: + +;; Initialize package system for batch mode +(when noninteractive + (package-initialize)) + +(require 'ert) + +;; Load dependencies required by pearl +(require 'request) +(require 'json) +(require 'dash) +(require 's) +(require 'org) +(require 'cl-lib) + +;; Load pearl from parent directory +(load (expand-file-name "../pearl.el") nil t) + +(provide 'test-bootstrap) +;;; test-bootstrap.el ends here diff --git a/tests/test-pearl-adhoc.el b/tests/test-pearl-adhoc.el new file mode 100644 index 0000000..97ac22e --- /dev/null +++ b/tests/test-pearl-adhoc.el @@ -0,0 +1,106 @@ +;;; test-pearl-adhoc.el --- Tests for the ad-hoc filtered command -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the ad-hoc filter command: the pure `--assemble-filter' that +;; turns chosen dimension values into a filter plist, `--save-query', and +;; `pearl-list-issues-filtered' running and optionally saving. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +;;; --assemble-filter + +(ert-deftest test-pearl-assemble-filter-only-set-keys () + "Only the dimensions that were chosen appear in the filter plist." + (let ((f (pearl--assemble-filter nil t nil nil nil nil))) + (should (eq t (plist-get f :open))) + (should-not (plist-member f :team)) + (should-not (plist-member f :labels)))) + +(ert-deftest test-pearl-assemble-filter-full () + "All chosen dimensions land in the plist." + (let ((f (pearl--assemble-filter "ENG" t "In Progress" "Foo" '("bug" "p1") :me))) + (should (string= "ENG" (plist-get f :team))) + (should (eq t (plist-get f :open))) + (should (string= "In Progress" (plist-get f :state))) + (should (string= "Foo" (plist-get f :project))) + (should (equal '("bug" "p1") (plist-get f :labels))) + (should (eq :me (plist-get f :assignee))))) + +(ert-deftest test-pearl-assemble-filter-empty-labels-omitted () + "An empty label list does not add a :labels key." + (let ((f (pearl--assemble-filter nil nil nil nil '() nil))) + (should-not (plist-member f :labels)))) + +;;; --save-query + +(ert-deftest test-pearl-save-query-adds-entry () + "Saving a query adds it to the saved-queries variable." + (let ((pearl-saved-queries nil)) + (cl-letf (((symbol-function 'customize-save-variable) (lambda (&rest _) nil))) + (pearl--save-query "My filter" '(:open t :labels ("bug"))) + (let ((entry (assoc "My filter" pearl-saved-queries))) + (should entry) + (should (equal '(:open t :labels ("bug")) (plist-get (cdr entry) :filter))))))) + +(ert-deftest test-pearl-save-query-replaces-same-name () + "Saving under an existing name replaces that entry rather than duplicating." + (let ((pearl-saved-queries '(("Dup" :filter (:open t))))) + (cl-letf (((symbol-function 'customize-save-variable) (lambda (&rest _) nil))) + (pearl--save-query "Dup" '(:priority 1)) + (should (= 1 (cl-count "Dup" pearl-saved-queries + :key #'car :test #'string=))) + (should (equal '(:priority 1) + (plist-get (cdr (assoc "Dup" pearl-saved-queries)) :filter)))))) + +;;; pearl-list-issues-filtered + +(ert-deftest test-pearl-list-issues-filtered-runs-with-source () + "Running an ad-hoc filter compiles it and renders with a filter source." + (let ((built nil) (rendered-source nil)) + (cl-letf (((symbol-function 'pearl--build-issue-filter) + (lambda (plist) (setq built plist) '((compiled . t)))) + ((symbol-function 'pearl--query-issues-async) + (lambda (_filter cb &optional _ord) + (funcall cb (pearl--make-query-result 'ok :issues nil)))) + ((symbol-function 'pearl--render-query-result) + (lambda (_result source) (setq rendered-source source)))) + (pearl-list-issues-filtered '(:assignee :me :open t) nil) + (should (equal '(:assignee :me :open t) built)) + (should (eq 'filter (plist-get rendered-source :type))) + (should (equal '(:assignee :me :open t) (plist-get rendered-source :filter)))))) + +(ert-deftest test-pearl-list-issues-filtered-saves-when-named () + "Passing a save name persists the ad-hoc filter as a saved query." + (let ((pearl-saved-queries nil)) + (cl-letf (((symbol-function 'pearl--build-issue-filter) (lambda (_p) nil)) + ((symbol-function 'pearl--query-issues-async) + (lambda (_f cb &optional _o) + (funcall cb (pearl--make-query-result 'empty :issues nil)))) + ((symbol-function 'pearl--render-query-result) (lambda (&rest _) nil)) + ((symbol-function 'customize-save-variable) (lambda (&rest _) nil))) + (pearl-list-issues-filtered '(:open t) "Saved adhoc") + (should (assoc "Saved adhoc" pearl-saved-queries))))) + +(provide 'test-pearl-adhoc) +;;; test-pearl-adhoc.el ends here diff --git a/tests/test-pearl-api.el b/tests/test-pearl-api.el new file mode 100644 index 0000000..bf4f45e --- /dev/null +++ b/tests/test-pearl-api.el @@ -0,0 +1,90 @@ +;;; test-pearl-api.el --- Tests for pearl core API layer -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the GraphQL request layer with `request' stubbed at the HTTP +;; boundary: the async entry point routes to success/error correctly and +;; balances the active-request counter; the sync wrapper returns data or nil. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) + +(ert-deftest test-pearl-graphql-request-async-success-routes-to-success-fn () + "A successful response is passed to the success function." + (let ((got nil)) + (testutil-linear-with-response '((data (viewer (name . "Me")))) + (pearl--graphql-request-async + "query" nil + (lambda (data) (setq got data)) + (lambda (&rest _) (setq got 'error)))) + (should (equal '((data (viewer (name . "Me")))) got)))) + +(ert-deftest test-pearl-graphql-request-async-error-routes-to-error-fn () + "A transport error is passed to the error function." + (let ((got nil)) + (testutil-linear-with-error "boom" + (pearl--graphql-request-async + "query" nil + (lambda (_d) (setq got 'success)) + (lambda (err _r _d) (setq got err)))) + (should (equal "boom" got)))) + +(ert-deftest test-pearl-graphql-request-async-balances-active-counter-on-success () + "The active-request counter returns to its starting value after success." + (let ((pearl--active-requests 0)) + (testutil-linear-with-response '((data)) + (pearl--graphql-request-async "q" nil #'ignore #'ignore)) + (should (= 0 pearl--active-requests)))) + +(ert-deftest test-pearl-graphql-request-async-nil-response-does-not-error () + "A transport error with a nil response routes to error-fn without throwing. + +The error handler logs the response status code; that read must be guarded +so a nil response (some transport failures) doesn't crash inside the handler." + (let ((pearl-api-key "test-key") (got nil)) + (cl-letf (((symbol-function 'request) + (lambda (_url &rest args) + (funcall (plist-get args :error) + :error-thrown "boom" :response nil :data nil)))) + (pearl--graphql-request-async + "q" nil #'ignore (lambda (err _r _d) (setq got err)))) + (should (equal "boom" got)))) + +(ert-deftest test-pearl-graphql-request-async-balances-active-counter-on-error () + "The active-request counter returns to its starting value after an error." + (let ((pearl--active-requests 0)) + (testutil-linear-with-error "boom" + (pearl--graphql-request-async "q" nil #'ignore #'ignore)) + (should (= 0 pearl--active-requests)))) + +(ert-deftest test-pearl-graphql-request-sync-returns-data () + "The synchronous wrapper returns the parsed response." + (testutil-linear-with-response '((data (x . 1))) + (should (equal '((data (x . 1))) (pearl--graphql-request "q"))))) + +(ert-deftest test-pearl-graphql-request-sync-error-returns-nil () + "The synchronous wrapper returns nil on a transport error." + (testutil-linear-with-error "boom" + (should (null (pearl--graphql-request "q"))))) + +(provide 'test-pearl-api) +;;; test-pearl-api.el ends here diff --git a/tests/test-pearl-assignee-labels.el b/tests/test-pearl-assignee-labels.el new file mode 100644 index 0000000..c70f0ca --- /dev/null +++ b/tests/test-pearl-assignee-labels.el @@ -0,0 +1,114 @@ +;;; test-pearl-assignee-labels.el --- Tests for set-assignee / set-labels -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the two drawer-field commands that resolve names to ids: +;; `pearl-set-assignee' and `pearl-set-labels'. They push via +;; the generic `--update-issue-async' and update the LINEAR-ASSIGNEE / LABELS +;; drawer. The resolver and the mutation are stubbed. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT at point-min." + (declare (indent 1)) + `(with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body)) + +;;; set-assignee + +(ert-deftest test-pearl-set-assignee-pushes-id-and-updates-drawer () + "Setting an assignee resolves the name, pushes the id, and updates the drawer." + (let ((pushed nil)) + (test-pearl--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TEAM-ID: team-1\n:LINEAR-ASSIGNEE-ID: old\n:LINEAR-ASSIGNEE-NAME: Someone\n:END:\n" + (cl-letf (((symbol-function 'pearl--resolve-team-id) + (lambda (_kind _name _team &optional _force) "u9")) + ((symbol-function 'pearl--update-issue-async) + (lambda (_id input cb) (setq pushed input) (funcall cb '(:success t))))) + (pearl-set-assignee "Craig") + (should (string= "u9" (cdr (assoc "assigneeId" pushed)))) + (should (string= "Craig" (org-entry-get nil "LINEAR-ASSIGNEE-NAME"))) + (should (string= "u9" (org-entry-get nil "LINEAR-ASSIGNEE-ID"))))))) + +(ert-deftest test-pearl-set-assignee-unresolvable-errors () + "An unresolvable assignee name signals a user error and pushes nothing." + (let ((pushed nil)) + (test-pearl--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TEAM-ID: team-1\n:END:\n" + (cl-letf (((symbol-function 'pearl--resolve-team-id) + (lambda (&rest _) nil)) + ((symbol-function 'pearl--update-issue-async) + (lambda (&rest _) (setq pushed t)))) + (should-error (pearl-set-assignee "Nobody") :type 'user-error) + (should-not pushed))))) + +(ert-deftest test-pearl-set-assignee-not-on-issue-errors () + "Setting an assignee outside a Linear issue heading signals a user error." + (test-pearl--in-org "* Plain heading\nno id\n" + (should-error (pearl-set-assignee "Craig") :type 'user-error))) + +;;; set-labels + +(ert-deftest test-pearl-set-labels-pushes-ids-and-updates-drawer () + "Setting labels resolves each name, pushes the id list, and updates the drawer." + (let ((pushed nil)) + (test-pearl--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TEAM-ID: team-1\n:LINEAR-LABELS: []\n:END:\n" + (cl-letf (((symbol-function 'pearl--resolve-team-id) + (lambda (_kind name _team &optional _force) + (pcase name ("bug" "l1") ("p1" "l2") (_ nil)))) + ((symbol-function 'pearl--update-issue-async) + (lambda (_id input cb) (setq pushed input) (funcall cb '(:success t))))) + (pearl-set-labels '("bug" "p1")) + (should (equal '("l1" "l2") (cdr (assoc "labelIds" pushed)))) + (should (string= "[bug, p1]" (org-entry-get nil "LINEAR-LABELS"))))))) + +(ert-deftest test-pearl-set-labels-clear-pushes-empty () + "Clearing labels (empty list) pushes an empty id list and empties the drawer." + (let ((pushed 'unset)) + (test-pearl--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TEAM-ID: team-1\n:LINEAR-LABELS: [bug]\n:END:\n" + (cl-letf (((symbol-function 'pearl--update-issue-async) + (lambda (_id input cb) (setq pushed input) (funcall cb '(:success t))))) + (pearl-set-labels '()) + (should (equal '() (cdr (assoc "labelIds" pushed)))) + (should (string= "[]" (org-entry-get nil "LINEAR-LABELS"))))))) + +(ert-deftest test-pearl-set-labels-unresolvable-errors () + "An unresolvable label name signals a user error and pushes nothing." + (let ((pushed nil)) + (test-pearl--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TEAM-ID: team-1\n:END:\n" + (cl-letf (((symbol-function 'pearl--resolve-team-id) + (lambda (&rest _) nil)) + ((symbol-function 'pearl--update-issue-async) + (lambda (&rest _) (setq pushed t)))) + (should-error (pearl-set-labels '("ghost")) :type 'user-error) + (should-not pushed))))) + +(provide 'test-pearl-assignee-labels) +;;; test-pearl-assignee-labels.el ends here diff --git a/tests/test-pearl-commands.el b/tests/test-pearl-commands.el new file mode 100644 index 0000000..77f2d46 --- /dev/null +++ b/tests/test-pearl-commands.el @@ -0,0 +1,153 @@ +;;; test-pearl-commands.el --- Tests for pearl user commands -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the interactive commands. Their input sources (completing-read, +;; read-string) and the network/file boundaries are stubbed so the dispatch +;; and orchestration logic runs: the list-issues result handling, project +;; dispatch, the new-issue input-building, and the connection/setup checks. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +;;; pearl-list-issues + +(ert-deftest test-pearl-list-issues-ok-writes-all-issues () + "On an ok result, every server-returned issue is written (no client filter)." + (let ((written nil)) + (cl-letf (((symbol-function 'pearl--query-issues-async) + (lambda (_filter cb &optional _order) + (funcall cb (pearl--make-query-result + 'ok :issues '(((identifier . "A")) ((identifier . "B"))))))) + ((symbol-function 'pearl--update-org-from-issues) + (lambda (issues &optional _source _truncated) (setq written issues)))) + (pearl-list-issues) + (should (= 2 (length written)))))) + +(ert-deftest test-pearl-list-issues-empty-skips-write () + "An empty result messages the user and does not overwrite the file." + (let ((wrote nil)) + (cl-letf (((symbol-function 'pearl--query-issues-async) + (lambda (_filter cb &optional _order) + (funcall cb (pearl--make-query-result 'empty :issues nil)))) + ((symbol-function 'pearl--update-org-from-issues) + (lambda (&rest _) (setq wrote t)))) + (pearl-list-issues) + (should-not wrote)))) + +(ert-deftest test-pearl-list-issues-error-skips-write () + "A failed query messages and does not write." + (let ((wrote nil)) + (cl-letf (((symbol-function 'pearl--query-issues-async) + (lambda (_filter cb &optional _order) + (funcall cb (pearl--make-query-result + 'request-failed :message "boom")))) + ((symbol-function 'pearl--update-org-from-issues) + (lambda (&rest _) (setq wrote t)))) + (pearl-list-issues) + (should-not wrote)))) + +(ert-deftest test-pearl-list-issues-project-id-adds-project-filter () + "A project id is compiled into the issue filter passed to the fetch." + (let (captured-filter) + (cl-letf (((symbol-function 'pearl--query-issues-async) + (lambda (filter _cb &optional _order) (setq captured-filter filter))) + ((symbol-function 'pearl--update-org-from-issues) #'ignore)) + (pearl-list-issues "proj-1") + (should (equal '(("id" ("eq" . "proj-1"))) (cdr (assoc "project" captured-filter))))))) + +;;; pearl-list-issues-by-project + +(ert-deftest test-pearl-list-issues-by-project-dispatches-with-project-id () + "Selecting a team and project forwards the project id to list-issues." + (let ((pid 'unset) + (pearl-default-team-id nil)) + (cl-letf (((symbol-function 'pearl-select-team) (lambda () '((id . "t1")))) + ((symbol-function 'pearl-select-project) + (lambda (_t) '((id . "p1") (name . "Platform")))) + ((symbol-function 'pearl-list-issues) (lambda (project-id) (setq pid project-id)))) + (pearl-list-issues-by-project) + (should (string-equal "p1" pid))))) + +(ert-deftest test-pearl-list-issues-by-project-no-team-stops () + "With no team selected, list-issues is not called." + (let ((called nil) + (pearl-default-team-id nil)) + (cl-letf (((symbol-function 'pearl-select-team) (lambda () nil)) + ((symbol-function 'pearl-list-issues) (lambda (&rest _) (setq called t)))) + (pearl-list-issues-by-project) + (should-not called)))) + +;;; pearl-new-issue + +(ert-deftest test-pearl-new-issue-success-returns-issue () + "new-issue builds the input, sends it, and returns the created issue." + (let ((pearl-default-team-id "team-1")) + (cl-letf (((symbol-function 'read-string) + (lambda (prompt &rest _) (if (string-prefix-p "Issue title" prompt) "My Issue" ""))) + ((symbol-function 'completing-read) + (lambda (prompt &rest _) + (cond ((string-prefix-p "State" prompt) "Todo") + ((string-prefix-p "Priority" prompt) "Medium") + ((string-prefix-p "Label category" prompt) "All") + (t "")))) + ((symbol-function 'pearl-get-states) + (lambda (_t) '(((id . "s1") (name . "Todo"))))) + ((symbol-function 'pearl-get-team-members) (lambda (_t) '())) + ((symbol-function 'pearl-get-issue-types) (lambda (_t) '())) + ((symbol-function 'pearl-select-project) (lambda (_t) nil)) + ((symbol-function 'pearl--graphql-request) + (lambda (_q &optional _v) + '((data (issueCreate (success . t) + (issue (id . "i1") (identifier . "ENG-1") (title . "My Issue")))))))) + (should (string-equal "ENG-1" (cdr (assoc 'identifier (pearl-new-issue)))))))) + +(ert-deftest test-pearl-new-issue-no-team-stops () + "new-issue stops cleanly when no team is selected." + (let ((pearl-default-team-id nil)) + (cl-letf (((symbol-function 'pearl-select-team) (lambda () nil))) + (should (progn (pearl-new-issue) t))))) + +;;; pearl-test-connection / check-setup + +(ert-deftest test-pearl-test-connection-success-runs () + "test-connection completes on a successful viewer response." + (testutil-linear-with-response '((data (viewer (id . "u") (name . "Me")))) + (should (progn (pearl-test-connection) t)))) + +(ert-deftest test-pearl-check-setup-with-key-tests-connection () + "check-setup runs the connection test when an API key is set." + (let ((pearl-api-key "k") (called nil)) + (cl-letf (((symbol-function 'pearl-test-connection) (lambda () (setq called t)))) + (pearl-check-setup) + (should called)))) + +(ert-deftest test-pearl-check-setup-without-key-skips-test () + "check-setup does not run the connection test without an API key." + (let ((pearl-api-key nil) (called nil)) + (cl-letf (((symbol-function 'pearl-test-connection) (lambda () (setq called t)))) + (pearl-check-setup) + (should-not called)))) + +(provide 'test-pearl-commands) +;;; test-pearl-commands.el ends here diff --git a/tests/test-pearl-comment-editing.el b/tests/test-pearl-comment-editing.el new file mode 100644 index 0000000..05a3a76 --- /dev/null +++ b/tests/test-pearl-comment-editing.el @@ -0,0 +1,240 @@ +;;; test-pearl-comment-editing.el --- Tests for editing comments -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for editing an existing comment (spec: docs/issue-comment-editing-spec.org). +;; Covers: the author-id retained at normalize time, the per-comment provenance +;; drawer, the editability predicate and highlight pass, the viewer/commentUpdate +;; network helpers (stubbed at the HTTP boundary), and the permission + conflict +;; gates of `pearl-edit-current-comment'. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT." + (declare (indent 1)) + `(let ((org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +;;; normalize-comment keeps the author id + +(ert-deftest test-pearl-normalize-comment-keeps-author-id () + "A user-authored comment retains the user id for the permission check." + (let ((c (pearl--normalize-comment + '((id . "c1") (body . "hi") (createdAt . "2026-05-24T10:00:00.000Z") + (user (id . "u-123") (name . "Craig")))))) + (should (string= "u-123" (plist-get c :author-id))) + (should (string= "Craig" (plist-get c :author))))) + +(ert-deftest test-pearl-normalize-comment-bot-has-no-author-id () + "A bot comment has no user, so author-id is nil (not editable)." + (let ((c (pearl--normalize-comment + '((id . "c1") (body . "hi") (createdAt . "2026-05-24T10:00:00.000Z") + (botActor (name . "Linear")))))) + (should (null (plist-get c :author-id))))) + +;;; format-comment writes the provenance drawer + +(ert-deftest test-pearl-format-comment-writes-drawer () + "A rendered comment carries id, author-id, and a body hash in a drawer." + (let ((out (pearl--format-comment + '(:id "c9" :author-id "u-123" :author "Craig" + :created-at "2026-05-24T10:00:00.000Z" :body "Looks good")))) + (should (string-match-p ":LINEAR-COMMENT-ID:[ \t]+c9" out)) + (should (string-match-p ":LINEAR-COMMENT-AUTHOR-ID:[ \t]+u-123" out)) + (should (string-match-p (format ":LINEAR-COMMENT-SHA256:[ \t]+%s" + (secure-hash 'sha256 "Looks good")) + out)))) + +(ert-deftest test-pearl-format-comment-bot-empty-author-id () + "A comment with no author id renders an empty author-id, not an error." + (let ((out (pearl--format-comment + '(:id "c1" :author "Linear" :created-at "2026-05-24T10:00:00.000Z" + :body "auto")))) + (should (string-match-p "^:LINEAR-COMMENT-AUTHOR-ID:[ \t]*$" out)))) + +;;; editability predicate + +(ert-deftest test-pearl-comment-editable-own () + "A comment whose author is the viewer is editable." + (should (pearl--comment-editable-p "u-1" "u-1"))) + +(ert-deftest test-pearl-comment-editable-other () + "A comment by another user is not editable." + (should-not (pearl--comment-editable-p "u-2" "u-1"))) + +(ert-deftest test-pearl-comment-editable-nil-author () + "A comment with no author id (bot/external) is not editable." + (should-not (pearl--comment-editable-p nil "u-1")) + (should-not (pearl--comment-editable-p "" "u-1"))) + +;;; viewer identity (cached) + +(ert-deftest test-pearl-viewer-async-parses-and-caches () + "The viewer query returns the id/name and caches it for the next call." + (let ((pearl--cache-viewer nil)) + (testutil-linear-with-response + '((data (viewer (id . "u-me") (name . "Craig")))) + (let (v) + (pearl--viewer-async (lambda (r) (setq v r))) + (should (string= "u-me" (plist-get v :id))) + (should (string= "u-me" (plist-get pearl--cache-viewer :id))))) + ;; second call uses the cache, no HTTP needed + (let ((v2 'untouched)) + (pearl--viewer-async (lambda (r) (setq v2 r))) + (should (string= "u-me" (plist-get v2 :id)))))) + +;;; commentUpdate write path + +(ert-deftest test-pearl-update-comment-success () + "A successful commentUpdate reports success." + (testutil-linear-with-response + '((data (commentUpdate (success . t) (comment (id . "c1") (body . "edited"))))) + (let (result) + (pearl--update-comment-async "c1" "edited" (lambda (r) (setq result r))) + (should (eq t (plist-get result :success)))))) + +(ert-deftest test-pearl-update-comment-soft-fail () + "A non-success commentUpdate reports failure rather than erroring." + (testutil-linear-with-response + '((data (commentUpdate (success . :json-false) (comment . nil)))) + (let (result) + (pearl--update-comment-async "c1" "x" (lambda (r) (setq result r))) + (should-not (plist-get result :success))))) + +;;; edit command — permission + conflict gates + +(defconst test-pearl--comment-buffer + (concat "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + "**** Comments\n" + "***** Craig — 2026-05-24T09:00:00.000Z\n" + ":PROPERTIES:\n" + ":LINEAR-COMMENT-ID: c1\n" + ":LINEAR-COMMENT-AUTHOR-ID: %s\n" + ":LINEAR-COMMENT-SHA256: %s\n" + ":END:\n" + "%s\n") + "Template: author-id, stored-sha, body.") + +(defun test-pearl--comment-doc (author-id stored-body current-body) + "Build a comment buffer: AUTHOR-ID, drawer hash of STORED-BODY, CURRENT-BODY shown." + (format test-pearl--comment-buffer + author-id (secure-hash 'sha256 stored-body) current-body)) + +(ert-deftest test-pearl-edit-comment-not-on-comment-errors () + "Running the edit command outside a comment subtree signals a user error." + (test-pearl--in-org "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + (should-error (pearl-edit-current-comment) :type 'user-error))) + +(ert-deftest test-pearl-edit-comment-refuses-others () + "Editing another user's comment refuses and never calls commentUpdate." + (test-pearl--in-org (test-pearl--comment-doc "u-other" "old" "new text") + (let ((pearl--cache-viewer '(:id "u-me" :name "Me")) + (updated nil) (fetched nil)) + (cl-letf (((symbol-function 'pearl--update-comment-async) + (lambda (&rest _) (setq updated t))) + ((symbol-function 'pearl--fetch-comment-body-async) + (lambda (&rest _) (setq fetched t)))) + (re-search-forward "new text") + (pearl-edit-current-comment) + (should-not updated) + (should-not fetched))))) + +(ert-deftest test-pearl-edit-comment-noop-when-unchanged () + "An unedited comment pushes nothing." + (test-pearl--in-org (test-pearl--comment-doc "u-me" "same" "same") + (let ((pearl--cache-viewer '(:id "u-me" :name "Me")) + (updated nil)) + (cl-letf (((symbol-function 'pearl--update-comment-async) + (lambda (&rest _) (setq updated t)))) + (re-search-forward "same") + (pearl-edit-current-comment) + (should-not updated))))) + +(ert-deftest test-pearl-edit-comment-pushes-own-edit () + "Editing your own comment against an unchanged remote pushes and advances the hash." + (test-pearl--in-org (test-pearl--comment-doc "u-me" "old body" "new body") + (let ((pearl--cache-viewer '(:id "u-me" :name "Me")) + (pushed-body nil)) + (cl-letf (((symbol-function 'pearl--fetch-comment-body-async) + ;; remote is unchanged since fetch (matches the stored hash) + (lambda (_id cb) (funcall cb "old body"))) + ((symbol-function 'pearl--update-comment-async) + (lambda (_id body cb) (setq pushed-body body) + (funcall cb '(:success t))))) + (re-search-forward "new body") + (pearl-edit-current-comment) + (should (string= "new body" pushed-body)) + ;; the stored hash advanced to the pushed body + (goto-char (point-min)) + (re-search-forward "^\\*\\*\\*\\*\\* Craig") + (should (string= (secure-hash 'sha256 "new body") + (org-entry-get nil "LINEAR-COMMENT-SHA256"))))))) + +(ert-deftest test-pearl-edit-comment-refuses-conflict () + "When the remote changed since the fetch, the edit is refused." + (test-pearl--in-org (test-pearl--comment-doc "u-me" "old body" "new body") + (let ((pearl--cache-viewer '(:id "u-me" :name "Me")) + (updated nil)) + (cl-letf (((symbol-function 'pearl--fetch-comment-body-async) + ;; remote drifted from the stored hash -> conflict + (lambda (_id cb) (funcall cb "remote changed body"))) + ((symbol-function 'pearl--update-comment-async) + (lambda (&rest _) (setq updated t))) + ;; On conflict the command now prompts; cancel keeps the old + ;; refuse behavior (no commentUpdate call). + ((symbol-function 'pearl--read-conflict-resolution) + (lambda (_label) 'cancel))) + (re-search-forward "new body") + (pearl-edit-current-comment) + (should-not updated))))) + +;;; editability highlighting + +(ert-deftest test-pearl-highlight-comments-colors-by-editability () + "Own comments get the editable face; others get the read-only face." + (test-pearl--in-org + (concat "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + "**** Comments\n" + "***** Me — 2026-05-24T09:00:00.000Z\n" + ":PROPERTIES:\n:LINEAR-COMMENT-ID: c1\n:LINEAR-COMMENT-AUTHOR-ID: u-me\n:END:\nmine\n" + "***** Them — 2026-05-24T10:00:00.000Z\n" + ":PROPERTIES:\n:LINEAR-COMMENT-ID: c2\n:LINEAR-COMMENT-AUTHOR-ID: u-other\n:END:\ntheirs\n") + (pearl--apply-comment-highlights "u-me") + (cl-flet ((face-on (pat) + (goto-char (point-min)) + (re-search-forward pat) + (goto-char (line-beginning-position)) + (let ((ov (cl-find-if (lambda (o) (overlay-get o 'pearl-comment)) + (overlays-at (point))))) + (and ov (overlay-get ov 'face))))) + (should (eq 'pearl-editable-comment (face-on "^\\*\\*\\*\\*\\* Me"))) + (should (eq 'pearl-readonly-comment (face-on "^\\*\\*\\*\\*\\* Them")))))) + +(provide 'test-pearl-comment-editing) +;;; test-pearl-comment-editing.el ends here diff --git a/tests/test-pearl-comments.el b/tests/test-pearl-comments.el new file mode 100644 index 0000000..7fa4482 --- /dev/null +++ b/tests/test-pearl-comments.el @@ -0,0 +1,170 @@ +;;; test-pearl-comments.el --- Tests for issue comments -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the comment thread: rendering a normalized comment and the +;; oldest-first Comments subtree, including comments in the issue render, the +;; commentCreate helper (stubbed at the HTTP boundary), the in-place append +;; under the Comments subtree (creating it when absent), and the +;; `pearl-add-comment' command. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT, default mapping bound." + (declare (indent 1)) + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE"))) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +;;; --format-comment / --format-comments + +(ert-deftest test-pearl-format-comment-renders-author-time-body () + "A comment renders as a level-4 heading with author and timestamp, body below." + (let ((out (pearl--format-comment + '(:id "c1" :author "Craig" :created-at "2026-05-23T10:00:00.000Z" + :body "Looks **good** to me")))) + (should (string-match-p "^\\*\\*\\*\\* Craig — 2026-05-23T10:00:00.000Z$" out)) + ;; body runs through the md->org tier + (should (string-match-p "Looks \\*good\\* to me" out)))) + +(ert-deftest test-pearl-format-comment-null-author () + "A comment with no resolved author renders a placeholder, not an error." + (let ((out (pearl--format-comment + '(:id "c1" :author nil :created-at "2026-05-23T10:00:00.000Z" :body "hi")))) + (should (string-match-p "^\\*\\*\\*\\* (unknown) — 2026-05-23T10:00:00.000Z$" out)))) + +(ert-deftest test-pearl-format-comments-empty-is-blank () + "No comments renders nothing (no empty Comments subtree)." + (should (string= "" (pearl--format-comments nil)))) + +(ert-deftest test-pearl-format-comments-oldest-first () + "Comments render under a Comments heading, oldest first regardless of input order." + (let ((out (pearl--format-comments + '((:id "c2" :author "B" :created-at "2026-05-23T12:00:00.000Z" :body "second") + (:id "c1" :author "A" :created-at "2026-05-23T09:00:00.000Z" :body "first"))))) + (should (string-match-p "^\\*\\*\\* Comments$" out)) + (should (< (string-match "first" out) (string-match "second" out))))) + +;;; comments in the issue render + +(ert-deftest test-pearl-format-issue-includes-comments () + "A normalized issue carrying comments renders the Comments subtree after the body." + (test-pearl--in-org "" + (let ((out (pearl--format-issue-as-org-entry + '(:id "u" :identifier "ENG-1" :title "Title" :priority 2 + :state (:name "Todo") :description "Body text." + :comments ((:id "c1" :author "A" :created-at "2026-05-23T09:00:00.000Z" + :body "a comment")))))) + (should (string-match-p "^\\*\\*\\* Comments$" out)) + (should (< (string-match "Body text." out) (string-match "a comment" out)))))) + +;;; --create-comment-async + +(ert-deftest test-pearl-create-comment-parses-payload () + "A successful commentCreate yields the normalized comment." + (testutil-linear-with-response + '((data (commentCreate + (success . t) + (comment (id . "c9") (body . "new one") + (createdAt . "2026-05-23T13:00:00.000Z") + (user (name . "Craig")))))) + (let (result) + (pearl--create-comment-async "issue-a" "new one" (lambda (r) (setq result r))) + (should (string= "c9" (plist-get result :id))) + (should (string= "Craig" (plist-get result :author)))))) + +(ert-deftest test-pearl-create-comment-soft-fail () + "A non-success commentCreate yields nil rather than erroring." + (testutil-linear-with-response + '((data (commentCreate (success . :json-false) (comment . nil)))) + (let ((called nil) (result 'untouched)) + (pearl--create-comment-async "issue-a" "x" (lambda (r) (setq called t result r))) + (should called) + (should (null result))))) + +;;; --append-comment-to-issue + +(ert-deftest test-pearl-append-comment-creates-subtree () + "Appending to an issue with no Comments subtree creates one." + (test-pearl--in-org + "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + (pearl--append-comment-to-issue + '(:id "c1" :author "A" :created-at "2026-05-23T09:00:00.000Z" :body "first comment")) + (goto-char (point-min)) + (should (re-search-forward "^\\*\\*\\* Comments$" nil t)) + (should (re-search-forward "first comment" nil t)))) + +(ert-deftest test-pearl-append-comment-after-existing () + "A new comment appends after an existing one under the Comments subtree." + (test-pearl--in-org + "** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n*** Comments\n**** A — 2026-05-23T09:00:00.000Z\nfirst\n" + (pearl--append-comment-to-issue + '(:id "c2" :author "B" :created-at "2026-05-23T12:00:00.000Z" :body "second")) + (goto-char (point-min)) + ;; only one Comments heading, and the new comment follows the first + (should (re-search-forward "^\\*\\*\\* Comments$" nil t)) + (should-not (re-search-forward "^\\*\\*\\* Comments$" nil t)) + (goto-char (point-min)) + (should (< (progn (re-search-forward "first") (point)) + (progn (re-search-forward "second") (point)))))) + +;;; pearl-add-comment + +(ert-deftest test-pearl-add-comment-appends-returned-comment () + "The command creates a comment and inserts the returned one in the buffer." + (test-pearl--in-org + "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + (cl-letf (((symbol-function 'pearl--create-comment-async) + (lambda (_id body cb) + (funcall cb (list :id "c1" :author "Craig" + :created-at "2026-05-23T14:00:00.000Z" :body body))))) + (re-search-forward "Body.") + (pearl-add-comment "my new comment") + (goto-char (point-min)) + (should (re-search-forward "^\\*\\*\\* Comments$" nil t)) + (should (re-search-forward "my new comment" nil t))))) + +(ert-deftest test-pearl-add-comment-reports-failure () + "A failed create does not insert a Comments subtree." + (test-pearl--in-org + "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + (cl-letf (((symbol-function 'pearl--create-comment-async) + (lambda (_id _body cb) (funcall cb nil)))) + (pearl-add-comment "x") + (goto-char (point-min)) + (should-not (re-search-forward "^\\*\\*\\* Comments$" nil t))))) + +(ert-deftest test-pearl-add-comment-not-on-issue-errors () + "Adding a comment outside a Linear issue heading signals a user error." + (test-pearl--in-org "* Plain heading\nno id\n" + (should-error (pearl-add-comment "x") :type 'user-error))) + +(provide 'test-pearl-comments) +;;; test-pearl-comments.el ends here diff --git a/tests/test-pearl-config.el b/tests/test-pearl-config.el new file mode 100644 index 0000000..e83414c --- /dev/null +++ b/tests/test-pearl-config.el @@ -0,0 +1,76 @@ +;;; test-pearl-config.el --- Tests for pearl config helpers -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unit tests for the small config / state helpers: `pearl--headers', +;; `pearl-toggle-debug', and `pearl-load-api-key-from-env'. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +;;; pearl--headers + +(ert-deftest test-pearl-headers-no-key-errors () + "Building headers without an API key signals an error." + (let ((pearl-api-key nil)) + (should-error (pearl--headers)))) + +(ert-deftest test-pearl-headers-with-key-sets-authorization () + "With a key set, the Authorization header carries the raw key (no Bearer)." + (let ((pearl-api-key "lin_api_abc123")) + (let ((headers (pearl--headers))) + (should (string-equal "lin_api_abc123" (cdr (assoc "Authorization" headers)))) + (should (string-equal "application/json" (cdr (assoc "Content-Type" headers))))))) + +;;; pearl-toggle-debug + +(ert-deftest test-pearl-toggle-debug-flips-from-nil () + "Toggling from nil enables debug." + (let ((pearl-debug nil)) + (pearl-toggle-debug) + (should (eq t pearl-debug)))) + +(ert-deftest test-pearl-toggle-debug-flips-from-t () + "Toggling from t disables debug." + (let ((pearl-debug t)) + (pearl-toggle-debug) + (should (null pearl-debug)))) + +;;; pearl-load-api-key-from-env + +(ert-deftest test-pearl-load-api-key-from-env-present () + "When LINEAR_API_KEY is set, the key is loaded into the variable." + (let ((process-environment (cons "LINEAR_API_KEY=env-key-xyz" process-environment)) + (pearl-api-key nil)) + (pearl-load-api-key-from-env) + (should (string-equal "env-key-xyz" pearl-api-key)))) + +(ert-deftest test-pearl-load-api-key-from-env-absent-leaves-key () + "When LINEAR_API_KEY is unset, the key variable is left unchanged." + (let ((process-environment + (seq-remove (lambda (e) (string-prefix-p "LINEAR_API_KEY=" e)) + process-environment)) + (pearl-api-key nil)) + (pearl-load-api-key-from-env) + (should (null pearl-api-key)))) + +(provide 'test-pearl-config) +;;; test-pearl-config.el ends here diff --git a/tests/test-pearl-conflict.el b/tests/test-pearl-conflict.el new file mode 100644 index 0000000..03d8f31 --- /dev/null +++ b/tests/test-pearl-conflict.el @@ -0,0 +1,282 @@ +;;; test-pearl-conflict.el --- Tests for interactive conflict resolution -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the conflict-resolution foundation: the no-data-loss stash +;; (`pearl--stash-conflict-text'), the smerge conflict-string builder +;; (`pearl--conflict-smerge-string'), and the resolution prompt +;; (`pearl--read-conflict-resolution', cancel-by-default). + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(defmacro test-pearl-conflict--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT, default mapping bound." + (declare (indent 1)) + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE"))) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +(defun test-pearl-conflict--marker () + "Return a marker at the first issue heading in the current buffer." + (goto-char (point-min)) + (re-search-forward "^\\*\\*\\* ") + (beginning-of-line) + (point-marker)) + +;;; --stash-conflict-text + +(ert-deftest test-pearl-stash-conflict-text-to-kill-ring-and-buffer () + "Stashing puts the text on the kill ring and into the backup buffer." + (let ((kill-ring nil)) + (when (get-buffer "*pearl-conflict-backup*") + (kill-buffer "*pearl-conflict-backup*")) + (pearl--stash-conflict-text "ENG-1 description" "My local edit.") + (should (string= "My local edit." (current-kill 0))) + (with-current-buffer "*pearl-conflict-backup*" + (let ((s (buffer-string))) + (should (string-match-p "ENG-1 description" s)) + (should (string-match-p "My local edit\\." s)))))) + +(ert-deftest test-pearl-stash-conflict-text-appends-not-overwrites () + "A second stash appends below the first, preserving earlier backups." + (let ((kill-ring nil)) + (when (get-buffer "*pearl-conflict-backup*") + (kill-buffer "*pearl-conflict-backup*")) + (pearl--stash-conflict-text "ENG-1 description" "First edit.") + (pearl--stash-conflict-text "ENG-2 title" "Second edit.") + (with-current-buffer "*pearl-conflict-backup*" + (let ((s (buffer-string))) + (should (string-match-p "First edit\\." s)) + (should (string-match-p "Second edit\\." s)))))) + +(ert-deftest test-pearl-stash-conflict-text-empty-is-noop () + "Stashing empty text touches neither the kill ring nor the backup buffer." + (let ((kill-ring nil)) + (when (get-buffer "*pearl-conflict-backup*") + (kill-buffer "*pearl-conflict-backup*")) + (pearl--stash-conflict-text "ENG-1 description" "") + (should (null kill-ring)) + (should-not (get-buffer "*pearl-conflict-backup*")))) + +;;; --conflict-smerge-string + +(ert-deftest test-pearl-conflict-smerge-string-has-markers-in-order () + "The smerge string carries the three markers with local before remote." + (let ((s (pearl--conflict-smerge-string "LOCAL TEXT" "REMOTE TEXT"))) + (should (string-match-p "^<<<<<<<" s)) + (should (string-match-p "^=======" s)) + (should (string-match-p "^>>>>>>>" s)) + (let ((lt (string-match "LOCAL TEXT" s)) + (sep (string-match "^=======" s)) + (rt (string-match "REMOTE TEXT" s))) + (should (< lt sep)) + (should (< sep rt))))) + +(ert-deftest test-pearl-conflict-smerge-string-newline-terminates-sections () + "Sections whose text lacks a trailing newline still get one before a marker." + (let ((s (pearl--conflict-smerge-string "no-newline-local" "no-newline-remote"))) + ;; The separator and closing markers must each start their own line. + (should (string-match-p "no-newline-local\n=======" s)) + (should (string-match-p "no-newline-remote\n>>>>>>>" s)))) + +;;; --read-conflict-resolution + +(ert-deftest test-pearl-read-conflict-resolution-maps-choices () + "Each prompt label maps to its resolution symbol." + (dolist (case '(("use local" . use-local) + ("use remote" . use-remote) + ("rewrite" . rewrite) + ("cancel" . cancel))) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt collection &rest _) + ;; Return the first offered label containing the case keyword. + (seq-find (lambda (c) (string-match-p (car case) c)) collection)))) + (should (eq (cdr case) (pearl--read-conflict-resolution "ENG-1 description")))))) + +(ert-deftest test-pearl-read-conflict-resolution-defaults-to-cancel () + "Selecting the default (a bare RET) resolves to `cancel'." + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _collection &rest args) + ;; Emulate RET-on-default: completing-read returns the DEF arg. + ;; args = (predicate require-match initial-input hist def ...), + ;; so DEF is the 5th element, index 4. + (nth 4 args)))) + (should (eq 'cancel (pearl--read-conflict-resolution "ENG-1 description"))))) + +;;; --set-entry-body-at-point + +(ert-deftest test-pearl-set-entry-body-replaces-body-keeps-drawer () + "Setting the body replaces the text after the drawer and preserves the drawer." + (test-pearl-conflict--in-org + "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: x\n:END:\nOld body.\n" + (re-search-forward "Title") + (pearl--set-entry-body-at-point "New body line.") + (goto-char (point-min)) + (should (re-search-forward "New body line\\." nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "Old body\\." nil t)) + (should (string= "a" (org-entry-get nil "LINEAR-ID"))))) + +(ert-deftest test-pearl-set-entry-body-stops-before-child-heading () + "Setting the body does not disturb a child Comments subtree." + (test-pearl-conflict--in-org + (concat "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nOld body.\n" + "**** Comments\n***** Me — t\nmine\n") + (re-search-forward "Title") + (pearl--set-entry-body-at-point "New body.") + (goto-char (point-min)) + (should (re-search-forward "New body\\." nil t)) + (should (re-search-forward "Comments" nil t)) + (should (re-search-forward "mine" nil t)))) + +;;; --resolve-conflict + +(ert-deftest test-pearl-resolve-conflict-cancel-does-nothing () + "Cancel applies nothing, pushes nothing, and leaves the provenance hash." + (test-pearl-conflict--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n" + (let ((applied nil) (pushed nil) (marker (test-pearl-conflict--marker))) + (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'cancel))) + (pearl--resolve-conflict + "ENG-1 description" "local" "remote" marker "LINEAR-DESC-SHA256" + (lambda (_md) (setq applied t)) + (lambda (_md cb) (setq pushed t) (funcall cb t))) + (should-not applied) + (should-not pushed) + (should (string= "H0" (org-entry-get marker "LINEAR-DESC-SHA256"))))))) + +(ert-deftest test-pearl-resolve-conflict-use-local-pushes-and-advances () + "Use-local pushes the local text and advances the hash to it on success." + (test-pearl-conflict--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n" + (let ((pushed-md nil) (applied nil) (marker (test-pearl-conflict--marker))) + (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'use-local))) + (pearl--resolve-conflict + "ENG-1 description" "local text" "remote text" marker "LINEAR-DESC-SHA256" + (lambda (_md) (setq applied t)) + (lambda (md cb) (setq pushed-md md) (funcall cb t))) + (should (string= "local text" pushed-md)) + (should-not applied) + (should (string= (secure-hash 'sha256 "local text") + (org-entry-get marker "LINEAR-DESC-SHA256"))))))) + +(ert-deftest test-pearl-resolve-conflict-use-remote-stashes-applies-no-push () + "Use-remote stashes local, writes remote, advances the hash, and never pushes." + (let ((kill-ring nil)) + (test-pearl-conflict--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n" + (let ((applied-md nil) (pushed nil) (marker (test-pearl-conflict--marker))) + (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'use-remote))) + (pearl--resolve-conflict + "ENG-1 description" "local text" "remote text" marker "LINEAR-DESC-SHA256" + (lambda (md) (setq applied-md md)) + (lambda (_md cb) (setq pushed t) (funcall cb t))) + (should (string= "remote text" applied-md)) + (should-not pushed) + (should (string= (secure-hash 'sha256 "remote text") + (org-entry-get marker "LINEAR-DESC-SHA256"))) + ;; the local edit was stashed, not lost + (should (string= "local text" (current-kill 0)))))))) + +(ert-deftest test-pearl-resolve-conflict-rewrite-applies-and-pushes () + "Rewrite stashes local, then on the smerge finish applies and pushes the merge." + (let ((kill-ring nil)) + (test-pearl-conflict--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: H0\n:END:\nbody\n" + (let ((applied nil) (pushed nil) (marker (test-pearl-conflict--marker))) + (cl-letf (((symbol-function 'pearl--read-conflict-resolution) (lambda (_) 'rewrite)) + ;; Emulate the user resolving the buffer and committing. + ((symbol-function 'pearl--resolve-conflict-in-smerge) + (lambda (_label _local _remote on-finish) + (funcall on-finish "merged text")))) + (pearl--resolve-conflict + "ENG-1 description" "local text" "remote text" marker "LINEAR-DESC-SHA256" + (lambda (md) (setq applied md)) + (lambda (md cb) (setq pushed md) (funcall cb t))) + (should (string= "local text" (current-kill 0))) + (should (string= "merged text" applied)) + (should (string= "merged text" pushed)) + (should (string= (secure-hash 'sha256 "merged text") + (org-entry-get marker "LINEAR-DESC-SHA256")))))))) + +;;; --conflict-has-markers-p + +(ert-deftest test-pearl-conflict-has-markers-p () + "Unresolved marker text reports markers; resolved text does not." + (should (pearl--conflict-has-markers-p + (pearl--conflict-smerge-string "mine" "theirs"))) + (should-not (pearl--conflict-has-markers-p "just the merged line\n"))) + +;;; --resolve-conflict-in-smerge (buffer setup) + +(ert-deftest test-pearl-resolve-conflict-in-smerge-sets-up-buffer () + "Opening the smerge buffer fills it with both sides and arms the callback." + (let ((buf-name "*pearl-merge: ENG-1 description*")) + (when (get-buffer buf-name) (kill-buffer buf-name)) + (cl-letf (((symbol-function 'pop-to-buffer) #'ignore)) + (pearl--resolve-conflict-in-smerge + "ENG-1 description" "my local" "the remote" (lambda (_) nil))) + (let ((buf (get-buffer buf-name))) + (should buf) + (with-current-buffer buf + (should (string-match-p "my local" (buffer-string))) + (should (string-match-p "the remote" (buffer-string))) + (should (bound-and-true-p smerge-mode)) + (should (functionp pearl--conflict-on-finish))) + (kill-buffer buf)))) + +;;; --conflict-commit / --conflict-abort + +(ert-deftest test-pearl-conflict-commit-refuses-with-markers () + "Committing with markers still present errors and never calls the callback." + (let ((called nil) (buf-name "*pearl-merge: ENG-1 description*")) + (when (get-buffer buf-name) (kill-buffer buf-name)) + (cl-letf (((symbol-function 'pop-to-buffer) #'ignore)) + (pearl--resolve-conflict-in-smerge + "ENG-1 description" "mine" "theirs" (lambda (_) (setq called t)))) + (with-current-buffer buf-name + (should-error (pearl--conflict-commit) :type 'user-error)) + (should-not called) + (when (get-buffer buf-name) (kill-buffer buf-name)))) + +(ert-deftest test-pearl-conflict-commit-resolved-calls-callback-and-kills () + "With markers resolved, commit hands the text to the callback and kills the buffer." + (let ((got nil) (buf-name "*pearl-merge: ENG-1 description*")) + (when (get-buffer buf-name) (kill-buffer buf-name)) + (cl-letf (((symbol-function 'pop-to-buffer) #'ignore)) + (pearl--resolve-conflict-in-smerge + "ENG-1 description" "mine" "theirs" (lambda (txt) (setq got txt)))) + (with-current-buffer buf-name + (erase-buffer) + (insert "the reconciled text\n") + (pearl--conflict-commit)) + (should (string= "the reconciled text\n" got)) + (should-not (get-buffer buf-name)))) + +(provide 'test-pearl-conflict) +;;; test-pearl-conflict.el ends here diff --git a/tests/test-pearl-convert.el b/tests/test-pearl-convert.el new file mode 100644 index 0000000..4125e22 --- /dev/null +++ b/tests/test-pearl-convert.el @@ -0,0 +1,172 @@ +;;; test-pearl-convert.el --- Tests for the markdown->org conversion -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for `pearl--md-to-org' and `pearl--md-line-to-org' -- +;; the pure-elisp markdown->org conversion tier. Cover each supported +;; construct (links, inline code, bold, underscore italics, headings, bullets, +;; fenced code), the heading-safety guard, and literal pass-through. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +;;; inline conversion + +(ert-deftest test-pearl-convert-link () + "A markdown link becomes an org link with url and label swapped." + (should (string= "see [[https://x.y][the docs]] now" + (pearl--md-line-to-org "see [the docs](https://x.y) now")))) + +(ert-deftest test-pearl-convert-inline-code () + "Inline code backticks become org verbatim tildes." + (should (string= "call ~foo()~ here" + (pearl--md-line-to-org "call `foo()` here")))) + +(ert-deftest test-pearl-convert-bold () + "Markdown bold becomes org bold." + (should (string= "a *strong* word" (pearl--md-line-to-org "a **strong** word")))) + +(ert-deftest test-pearl-convert-italic-underscore () + "Underscore italics become org italics, but identifiers are left alone." + (should (string= "an /emphatic/ point" + (pearl--md-line-to-org "an _emphatic_ point"))) + (should (string= "the foo_bar_baz name" + (pearl--md-line-to-org "the foo_bar_baz name")))) + +;;; line / block conversion + +(ert-deftest test-pearl-convert-heading-to-bold () + "A markdown heading becomes a bold line, never an org heading." + (let ((out (pearl--md-to-org "## Big Heading"))) + (should (string= "*Big Heading*" out)) + (should-not (string-match-p "^\\*+ " out)))) + +(ert-deftest test-pearl-convert-bullets () + "Markdown `*' and `+' bullets become org `-' bullets." + (should (string= "- one\n- two" + (pearl--md-to-org "* one\n+ two")))) + +(ert-deftest test-pearl-convert-fenced-code () + "A fenced code block becomes a src block, verbatim inside." + (should (string= "#+begin_src elisp\n(+ 1 2)\n#+end_src" + (pearl--md-to-org "```elisp\n(+ 1 2)\n```")))) + +(ert-deftest test-pearl-convert-code-block-is-verbatim () + "Inline markup inside a fenced block is not converted." + (let ((out (pearl--md-to-org "```\n**not bold** here\n```"))) + (should (string-match-p "\\*\\*not bold\\*\\*" out)))) + +(ert-deftest test-pearl-convert-guards-heading-line () + "A non-bullet line that Org would read as a heading is space-guarded." + (let ((out (pearl--md-to-org "** looks like a heading"))) + (should-not (string-match-p "^\\*+ " out)) + (should (string-prefix-p " " out)))) + +(ert-deftest test-pearl-convert-passes-through-plain-and-tables () + "Plain text and unsupported constructs (tables) pass through unchanged." + (should (string= "just some text" (pearl--md-to-org "just some text"))) + (should (string= "| a | b |\n|---|---|" + (pearl--md-to-org "| a | b |\n|---|---|")))) + +(ert-deftest test-pearl-convert-empty () + "An empty or nil description converts to the empty string." + (should (string= "" (pearl--md-to-org ""))) + (should (string= "" (pearl--md-to-org nil)))) + +;;; org -> markdown (the push direction) + +(ert-deftest test-pearl-org-to-md-link () + "An org link becomes a markdown link with label and url swapped back." + (should (string= "see [the docs](https://x.y) now" + (pearl--org-line-to-md "see [[https://x.y][the docs]] now")))) + +(ert-deftest test-pearl-org-to-md-bare-link () + "An org link with no description becomes the bare url." + (should (string= "visit https://x.y" + (pearl--org-line-to-md "visit [[https://x.y]]")))) + +(ert-deftest test-pearl-org-to-md-inline-code () + "Org verbatim tildes become markdown backticks." + (should (string= "call `foo()` here" + (pearl--org-line-to-md "call ~foo()~ here")))) + +(ert-deftest test-pearl-org-to-md-bold () + "Org bold becomes markdown bold." + (should (string= "a **strong** word" (pearl--org-line-to-md "a *strong* word")))) + +(ert-deftest test-pearl-org-to-md-italic () + "Org italics become underscore italics, but paths are left alone." + (should (string= "an _emphatic_ point" + (pearl--org-line-to-md "an /emphatic/ point"))) + (should (string= "the /usr/local/bin path" + (pearl--org-line-to-md "the /usr/local/bin path")))) + +(ert-deftest test-pearl-org-to-md-fenced-code () + "An org src block becomes a fenced code block, language preserved." + (should (string= "```elisp\n(+ 1 2)\n```" + (pearl--org-to-md "#+begin_src elisp\n(+ 1 2)\n#+end_src")))) + +(ert-deftest test-pearl-org-to-md-code-block-is-verbatim () + "Org markup inside a src block is not converted back." + (let ((out (pearl--org-to-md "#+begin_src\n*not bold* here\n#+end_src"))) + (should (string-match-p "\\*not bold\\* here" out)))) + +(ert-deftest test-pearl-org-to-md-quote-block () + "An org quote block becomes markdown blockquote lines." + (should (string= "> a quote\n> second line" + (pearl--org-to-md + "#+begin_quote\na quote\nsecond line\n#+end_quote")))) + +(ert-deftest test-pearl-org-to-md-checkbox-case () + "Org uppercase checkbox marks normalize to markdown lowercase." + (should (string= "- [ ] todo\n- [x] done" + (pearl--org-to-md "- [ ] todo\n- [X] done")))) + +(ert-deftest test-pearl-org-to-md-empty () + "An empty or nil body converts to the empty string." + (should (string= "" (pearl--org-to-md ""))) + (should (string= "" (pearl--org-to-md nil)))) + +(ert-deftest test-pearl-org-to-md-passes-through-tables () + "Tables and unsupported constructs pass through unchanged." + (should (string= "| a | b |\n|---|---|" + (pearl--org-to-md "| a | b |\n|---|---|")))) + +;;; round-trip: org-to-md inverts md-to-org for the supported subset + +(ert-deftest test-pearl-convert-roundtrip-identity () + "For the cleanly-supported constructs, org->md(md->org(x)) == x. +Markdown headings and single-asterisk italics are intentionally lossy (see +the conversion-tier docstring) and are excluded here." + (dolist (md '("a **strong** word" + "call `foo()` here" + "an _emphatic_ point" + "see [the docs](https://x.y) now" + "- one\n- two\n- three" + "1. first\n2. second" + "- [ ] todo\n- [x] done" + "```elisp\n(+ 1 2)\n```" + "just some plain prose" + "| a | b |\n|---|---|")) + (should (string= md (pearl--org-to-md (pearl--md-to-org md)))))) + +(provide 'test-pearl-convert) +;;; test-pearl-convert.el ends here diff --git a/tests/test-pearl-delete.el b/tests/test-pearl-delete.el new file mode 100644 index 0000000..bd412c7 --- /dev/null +++ b/tests/test-pearl-delete.el @@ -0,0 +1,97 @@ +;;; test-pearl-delete.el --- Tests for deleting an issue -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for `pearl--delete-issue-async' (the issueDelete mutation, +;; stubbed) and `pearl-delete-current-issue', which confirms, deletes, +;; and removes the issue subtree from the buffer on success. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT at point-min." + (declare (indent 1)) + `(with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body)) + +;;; --delete-issue-async + +(ert-deftest test-pearl-delete-issue-async-success () + "A successful issueDelete reports success." + (testutil-linear-with-response + '((data (issueDelete (success . t)))) + (let (result) + (pearl--delete-issue-async "id-1" (lambda (r) (setq result r))) + (should (eq t (plist-get result :success)))))) + +(ert-deftest test-pearl-delete-issue-async-soft-fail () + "A non-success issueDelete reports failure rather than erroring." + (testutil-linear-with-response + '((data (issueDelete (success . :json-false)))) + (let ((called nil) result) + (pearl--delete-issue-async "id-1" (lambda (r) (setq called t result r))) + (should called) + (should-not (plist-get result :success))))) + +;;; delete-current-issue + +(ert-deftest test-pearl-delete-current-issue-confirmed-removes-subtree () + "Confirming the delete removes the issue subtree from the buffer." + (test-pearl--in-org + "* Header\n\n*** TODO ENG-1 Doomed\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-IDENTIFIER: ENG-1\n:END:\nbody\n*** TODO ENG-2 Survivor\n:PROPERTIES:\n:LINEAR-ID: b\n:END:\n" + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'pearl--delete-issue-async) + (lambda (_id cb) (funcall cb '(:success t))))) + (re-search-forward "Doomed") + (pearl-delete-current-issue) + (goto-char (point-min)) + (should-not (re-search-forward "Doomed" nil t)) + ;; the sibling issue is untouched + (goto-char (point-min)) + (should (re-search-forward "Survivor" nil t))))) + +(ert-deftest test-pearl-delete-current-issue-declined-keeps-subtree () + "Declining the confirmation makes no API call and leaves the subtree." + (let ((called nil)) + (test-pearl--in-org + "*** TODO ENG-1 Keepme\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nbody\n" + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) nil)) + ((symbol-function 'pearl--delete-issue-async) + (lambda (&rest _) (setq called t)))) + (pearl-delete-current-issue) + (should-not called) + (goto-char (point-min)) + (should (re-search-forward "Keepme" nil t)))))) + +(ert-deftest test-pearl-delete-current-issue-not-on-issue-errors () + "Deleting outside a Linear issue heading signals a user error." + (test-pearl--in-org "* Plain heading\nno id\n" + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t))) + (should-error (pearl-delete-current-issue) :type 'user-error)))) + +(provide 'test-pearl-delete) +;;; test-pearl-delete.el ends here diff --git a/tests/test-pearl-fields.el b/tests/test-pearl-fields.el new file mode 100644 index 0000000..7322e4f --- /dev/null +++ b/tests/test-pearl-fields.el @@ -0,0 +1,153 @@ +;;; test-pearl-fields.el --- Tests for command-managed drawer fields -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the command-managed drawer fields that need no name->id +;; resolution helper: set-priority and set-state. Covers the generic +;; issueUpdate helper (stubbed at the HTTP boundary), the heading cookie and +;; keyword/drawer mutators, and the two commands' push + buffer-update paths. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT, default mapping bound." + (declare (indent 1)) + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE"))) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +;;; --update-issue-async (generic issueUpdate) + +(ert-deftest test-pearl-update-issue-async-success () + "A successful generic issueUpdate reports success and the timestamp." + (testutil-linear-with-response + '((data (issueUpdate (success . t) (issue (id . "a") (updatedAt . "t1"))))) + (let (result) + (pearl--update-issue-async "a" '(("priority" . 2)) (lambda (r) (setq result r))) + (should (eq t (plist-get result :success))) + (should (string= "t1" (plist-get result :updated-at)))))) + +(ert-deftest test-pearl-update-issue-async-soft-fail () + "A non-success generic issueUpdate reports failure rather than erroring." + (testutil-linear-with-response + '((data (issueUpdate (success . :json-false) (issue . nil)))) + (let ((called nil) result) + (pearl--update-issue-async "a" '(("priority" . 2)) (lambda (r) (setq called t result r))) + (should called) + (should-not (plist-get result :success))))) + +;;; --set-priority-cookie + +(ert-deftest test-pearl-set-priority-cookie-replaces () + "Setting a priority rewrites the heading cookie." + (test-pearl--in-org "*** TODO [#C] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (pearl--set-priority-cookie 1) + (goto-char (point-min)) + (should (string-match-p "^\\*\\*\\* TODO \\[#A\\] Title" (thing-at-point 'line t))))) + +(ert-deftest test-pearl-set-priority-cookie-low () + "Low priority renders the #D cookie." + (test-pearl--in-org "*** TODO [#C] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (pearl--set-priority-cookie 4) + (goto-char (point-min)) + (should (string-match-p "^\\*\\*\\* TODO \\[#D\\] Title" (thing-at-point 'line t))))) + +(ert-deftest test-pearl-set-priority-cookie-none-removes () + "Priority None removes the cookie." + (test-pearl--in-org "*** TODO [#C] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (pearl--set-priority-cookie 0) + (goto-char (point-min)) + (should (string-match-p "^\\*\\*\\* TODO Title" (thing-at-point 'line t))) + (should-not (string-match-p "\\[#" (thing-at-point 'line t))))) + +;;; pearl-set-priority + +(ert-deftest test-pearl-set-priority-pushes-and-updates-cookie () + "Setting priority pushes the numeric value and rewrites the cookie." + (let ((pushed nil)) + (test-pearl--in-org "*** TODO [#C] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (cl-letf (((symbol-function 'pearl--update-issue-async) + (lambda (_id input cb) (setq pushed input) (funcall cb '(:success t))))) + (re-search-forward "Title") + (pearl-set-priority "High") + (should (equal 2 (cdr (assoc "priority" pushed)))) + (goto-char (point-min)) + (should (string-match-p "\\[#B\\]" (thing-at-point 'line t))))))) + +(ert-deftest test-pearl-set-priority-not-on-issue-errors () + "Setting priority outside a Linear issue heading signals a user error." + (test-pearl--in-org "* Plain heading\nno id\n" + (should-error (pearl-set-priority "High") :type 'user-error))) + +;;; --set-heading-state + +(ert-deftest test-pearl-set-heading-state-updates-keyword-and-drawer () + "Setting the heading state updates the TODO keyword and the LINEAR-STATE drawer." + (test-pearl--in-org + "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-STATE-ID: old\n:LINEAR-STATE-NAME: Todo\n:END:\n" + (pearl--set-heading-state "In Progress" "s2") + (goto-char (point-min)) + (should (string-match-p "^\\*\\*\\* IN-PROGRESS " (thing-at-point 'line t))) + (should (string= "In Progress" (org-entry-get nil "LINEAR-STATE-NAME"))) + (should (string= "s2" (org-entry-get nil "LINEAR-STATE-ID"))))) + +(ert-deftest test-pearl-set-heading-state-does-not-fire-sync-hook () + "Setting the keyword must not trigger the Linear org-todo sync hook." + (let ((fired nil)) + (test-pearl--in-org + "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (let ((org-after-todo-state-change-hook (list (lambda () (setq fired t))))) + (pearl--set-heading-state "Done" "s3") + (should-not fired))))) + +;;; pearl-set-state + +(ert-deftest test-pearl-set-state-pushes-id-and-updates-heading () + "Setting state resolves the name to an id, pushes it, and updates the heading." + (let ((pushed nil)) + (test-pearl--in-org + "*** TODO [#B] Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TEAM-ID: team-1\n:END:\n" + (cl-letf (((symbol-function 'pearl--team-states) + (lambda (_team) '(((id . "s1") (name . "Todo")) + ((id . "s2") (name . "In Progress"))))) + ((symbol-function 'pearl--update-issue-async) + (lambda (_id input cb) (setq pushed input) (funcall cb '(:success t))))) + (pearl-set-state "In Progress") + (should (string= "s2" (cdr (assoc "stateId" pushed)))) + (goto-char (point-min)) + (should (string-match-p "^\\*\\*\\* IN-PROGRESS " (thing-at-point 'line t))) + (should (string= "In Progress" (org-entry-get nil "LINEAR-STATE-NAME"))))))) + +(ert-deftest test-pearl-set-state-not-on-issue-errors () + "Setting state outside a Linear issue heading signals a user error." + (test-pearl--in-org "* Plain heading\nno id\n" + (should-error (pearl-set-state "Done") :type 'user-error))) + +(provide 'test-pearl-fields) +;;; test-pearl-fields.el ends here diff --git a/tests/test-pearl-filter.el b/tests/test-pearl-filter.el new file mode 100644 index 0000000..6143311 --- /dev/null +++ b/tests/test-pearl-filter.el @@ -0,0 +1,193 @@ +;;; test-pearl-filter.el --- Tests for the issue filter DSL -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the Layer 1 issue-filter DSL: `pearl--build-issue-filter' +;; (and its predicate helpers) and `pearl--validate-issue-filter'. All +;; pure -- no network. Each authoring key is checked in isolation, then in +;; combination (sibling clauses AND-ed), with `:state'/`:open' precedence and a +;; json-encode round-trip; validation covers the error cases. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'json) + +;;; predicate helpers + +(ert-deftest test-pearl-filter-eq-helper () + "`--eq' wraps a value in an eq comparator." + (should (equal (pearl--eq "x") '(("eq" . "x")))) + (should (equal (pearl--eq t) '(("eq" . t))))) + +(ert-deftest test-pearl-filter-in-nin-helpers-make-vectors () + "`--in' / `--nin' encode their values as JSON arrays (vectors)." + (should (equal (pearl--in '("a" "b")) '(("in" . ["a" "b"])))) + (should (equal (pearl--nin '("a")) '(("nin" . ["a"]))))) + +;;; compile-priority + +(ert-deftest test-pearl-filter-compile-priority-symbol-and-int () + "Priority symbols map to numbers; integers pass through." + (should (= 1 (pearl--compile-priority 'urgent))) + (should (= 0 (pearl--compile-priority 'none))) + (should (= 4 (pearl--compile-priority 'low))) + (should (= 3 (pearl--compile-priority 3)))) + +;;; build-issue-filter -- single dimensions (Normal) + +(ert-deftest test-pearl-filter-assignee-me () + ":assignee :me compiles to assignee.isMe.eq true." + (should (equal (pearl--build-issue-filter '(:assignee :me)) + '(("assignee" ("isMe" ("eq" . t))))))) + +(ert-deftest test-pearl-filter-assignee-email () + ":assignee with an email compiles to assignee.email.eq." + (should (equal (pearl--build-issue-filter '(:assignee "x@y.com")) + '(("assignee" ("email" ("eq" . "x@y.com"))))))) + +(ert-deftest test-pearl-filter-open () + ":open t compiles to state.type nin the closed types." + (should (equal (pearl--build-issue-filter '(:open t)) + '(("state" ("type" ("nin" . ["completed" "canceled" "duplicate"]))))))) + +(ert-deftest test-pearl-filter-state-name () + ":state compiles to state.name.eq." + (should (equal (pearl--build-issue-filter '(:state "In Progress")) + '(("state" ("name" ("eq" . "In Progress"))))))) + +(ert-deftest test-pearl-filter-state-type-list () + ":state-type with a list compiles to state.type.in." + (should (equal (pearl--build-issue-filter '(:state-type ("started" "unstarted"))) + '(("state" ("type" ("in" . ["started" "unstarted"]))))))) + +(ert-deftest test-pearl-filter-state-type-single () + ":state-type with a bare string is wrapped into a one-element array." + (should (equal (pearl--build-issue-filter '(:state-type "started")) + '(("state" ("type" ("in" . ["started"]))))))) + +(ert-deftest test-pearl-filter-project-team-cycle () + ":project / :cycle compile to id.eq; :team to key.eq." + (should (equal (pearl--build-issue-filter '(:project "p-1")) + '(("project" ("id" ("eq" . "p-1")))))) + (should (equal (pearl--build-issue-filter '(:team "ENG")) + '(("team" ("key" ("eq" . "ENG")))))) + (should (equal (pearl--build-issue-filter '(:cycle "c-1")) + '(("cycle" ("id" ("eq" . "c-1"))))))) + +(ert-deftest test-pearl-filter-labels-any-of () + ":labels compiles to labels.some.name.in (carries any of the listed labels)." + (should (equal (pearl--build-issue-filter '(:labels ("bug" "p1"))) + '(("labels" ("some" ("name" ("in" . ["bug" "p1"])))))))) + +(ert-deftest test-pearl-filter-priority-symbol () + ":priority symbol compiles to priority.eq with the numeric value." + (should (equal (pearl--build-issue-filter '(:priority high)) + '(("priority" ("eq" . 2)))))) + +;;; precedence (:state / :state-type win over :open) + +(ert-deftest test-pearl-filter-explicit-state-beats-open () + "An explicit :state overrides :open." + (should (equal (pearl--build-issue-filter '(:open t :state "Done")) + '(("state" ("name" ("eq" . "Done"))))))) + +(ert-deftest test-pearl-filter-state-type-beats-open () + ":state-type overrides :open." + (should (equal (pearl--build-issue-filter '(:open t :state-type ("started"))) + '(("state" ("type" ("in" . ["started"]))))))) + +;;; composition (sibling clauses AND-ed) + ordering keys ignored + +(ert-deftest test-pearl-filter-composition-keeps-all-clauses () + "Multiple keys produce sibling clauses; :sort/:order don't affect the filter." + (let ((f (pearl--build-issue-filter + '(:assignee :me :open t :project "p-1" :labels ("bug") + :priority urgent :sort updated :order desc)))) + (should (assoc "assignee" f)) + (should (assoc "state" f)) + (should (assoc "project" f)) + (should (assoc "labels" f)) + (should (assoc "priority" f)) + ;; ordering keys are not part of the IssueFilter + (should-not (assoc "sort" f)) + (should-not (assoc "order" f)))) + +;;; boundary + +(ert-deftest test-pearl-filter-empty-plist-empty-filter () + "An empty plist compiles to an empty filter." + (should (null (pearl--build-issue-filter '())))) + +(ert-deftest test-pearl-filter-priority-zero-kept () + ":priority 0 (none) is kept, not treated as absent." + (should (equal (pearl--build-issue-filter '(:priority 0)) + '(("priority" ("eq" . 0)))))) + +;;; json-encode round-trip (proves the alist shape renders the right JSON) + +(ert-deftest test-pearl-filter-json-encodes-as-expected () + "The compiled filter json-encodes to the expected IssueFilter JSON." + (should (string= (json-encode (pearl--build-issue-filter '(:assignee :me :open t))) + (concat "{\"assignee\":{\"isMe\":{\"eq\":true}}," + "\"state\":{\"type\":{\"nin\":" + "[\"completed\",\"canceled\",\"duplicate\"]}}}")))) + +;;; validation (Error cases) + +(ert-deftest test-pearl-filter-validate-accepts-good-filter () + "A well-formed filter validates to t." + (should (eq t (pearl--validate-issue-filter + '(:assignee :me :open t :priority high :labels ("bug") :order desc))))) + +(ert-deftest test-pearl-filter-validate-rejects-unknown-key () + "An unknown key is a user-error." + (should-error (pearl--validate-issue-filter '(:bogus 1)) :type 'user-error)) + +(ert-deftest test-pearl-filter-validate-rejects-odd-plist () + "A plist with an odd number of elements is a user-error." + (should-error (pearl--validate-issue-filter '(:open)) :type 'user-error)) + +(ert-deftest test-pearl-filter-validate-rejects-bad-priority-symbol () + "An unrecognized priority symbol is a user-error." + (should-error (pearl--validate-issue-filter '(:priority huge)) :type 'user-error)) + +(ert-deftest test-pearl-filter-validate-rejects-priority-out-of-range () + "A priority integer outside 0-4 is a user-error." + (should-error (pearl--validate-issue-filter '(:priority 9)) :type 'user-error)) + +(ert-deftest test-pearl-filter-validate-rejects-bad-assignee () + "An :assignee that is neither :me nor a string is a user-error." + (should-error (pearl--validate-issue-filter '(:assignee 42)) :type 'user-error)) + +(ert-deftest test-pearl-filter-validate-rejects-empty-string () + "An empty string for a value key is a user-error." + (should-error (pearl--validate-issue-filter '(:project "")) :type 'user-error)) + +(ert-deftest test-pearl-filter-validate-rejects-bad-order () + "An :order other than asc/desc is a user-error." + (should-error (pearl--validate-issue-filter '(:order sideways)) :type 'user-error)) + +(ert-deftest test-pearl-filter-validate-rejects-non-string-label () + "A non-string entry in :labels is a user-error." + (should-error (pearl--validate-issue-filter '(:labels ("bug" 7))) :type 'user-error)) + +(provide 'test-pearl-filter) +;;; test-pearl-filter.el ends here diff --git a/tests/test-pearl-fixtures.el b/tests/test-pearl-fixtures.el new file mode 100644 index 0000000..dfd9e1d --- /dev/null +++ b/tests/test-pearl-fixtures.el @@ -0,0 +1,68 @@ +;;; test-pearl-fixtures.el --- smoke tests for the API fixtures -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Smoke tests for `testutil-fixtures'. The fixtures exist for the upcoming +;; query/representation tests, which don't exist yet, so without this file the +;; suite would never load the fixtures and a syntax slip or shape change would +;; rot unnoticed. These assertions exercise the file and lock the key shapes +;; the consuming tests will rely on (json-read conventions: missing keys for +;; absent fields, `t' / `:json-false' booleans). + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-fixtures (expand-file-name "testutil-fixtures.el")) + +(ert-deftest test-pearl-fixture-assigned-page-shape () + "The assignedIssues page fixture has nodes and a pageInfo." + (let* ((page (testutil-linear-fixture-assigned-issues-page)) + (conn (cdr (assoc 'assignedIssues + (assoc 'viewer (assoc 'data page)))))) + (should (= 2 (length (cdr (assoc 'nodes conn))))) + (should (eq :json-false (cdr (assoc 'hasNextPage (assoc 'pageInfo conn))))))) + +(ert-deftest test-pearl-fixture-null-fields-omits-optionals () + "The null-fields issue carries empty/absent project, assignee, and labels." + (let ((issue (testutil-linear-fixture-issue-null-fields))) + ;; present-but-empty: the key exists with a nil value (JSON null) + (should (assoc 'project issue)) + (should (null (cdr (assoc 'project issue)))) + (should (null (cdr (assoc 'assignee issue)))) + ;; labels is an empty connection, not missing + (should (null (cdr (assoc 'nodes (assoc 'labels issue))))))) + +(ert-deftest test-pearl-fixture-custom-views-shape () + "The customViews fixture exposes named views with a shared flag." + (let* ((views (cdr (assoc 'nodes (assoc 'customViews + (assoc 'data (testutil-linear-fixture-custom-views))))))) + (should (= 2 (length views))) + (should (string-equal "My open work" (cdr (assoc 'name (car views))))) + (should (eq t (cdr (assoc 'shared (cadr views))))))) + +(ert-deftest test-pearl-fixture-comments-oldest-first () + "The issue-with-comments fixture orders comments oldest first." + (let ((comments (cdr (assoc 'nodes (assoc 'comments + (testutil-linear-fixture-issue-with-comments)))))) + (should (= 2 (length comments))) + (should (string-equal "First comment" (cdr (assoc 'body (car comments))))))) + +(provide 'test-pearl-fixtures) +;;; test-pearl-fixtures.el ends here diff --git a/tests/test-pearl-format.el b/tests/test-pearl-format.el new file mode 100644 index 0000000..7310413 --- /dev/null +++ b/tests/test-pearl-format.el @@ -0,0 +1,188 @@ +;;; test-pearl-format.el --- Tests for org entry rendering -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the org renderer: `pearl--format-issue-as-org-entry' (a +;; normalized issue plist -> heading + LINEAR-* drawer + body description), +;; `pearl--description-to-org-body' (the interim heading guard), and +;; `pearl--build-org-content'. Issues come from the shared fixtures via +;; `pearl--normalize-issue', so the renderer is exercised on the same +;; shapes production hands it. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-fixtures (expand-file-name "testutil-fixtures.el")) + +(defmacro test-pearl--with-default-mapping (&rest body) + "Run BODY with the default state mapping and a clean pattern cache." + (declare (indent 0)) + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") + ("In Review" . "IN-REVIEW") ("Backlog" . "BACKLOG") + ("Blocked" . "BLOCKED") ("Done" . "DONE"))) + (pearl-todo-states-pattern nil) + (pearl--todo-states-pattern-source nil)) + ,@body)) + +(defun test-pearl--norm-full () + "A normalized fully-populated issue." + (pearl--normalize-issue (testutil-linear-fixture-issue-full))) + +(defun test-pearl--norm-bare () + "A normalized issue with null/missing optional fields." + (pearl--normalize-issue (testutil-linear-fixture-issue-null-fields))) + +;;; format-issue-as-org-entry + +(ert-deftest test-pearl-format-issue-full-renders-heading-and-drawer () + "A full issue renders the heading and the namespaced LINEAR-* drawer." + (test-pearl--with-default-mapping + (let ((out (pearl--format-issue-as-org-entry (test-pearl--norm-full)))) + (should (string-match-p "^\\*\\* IN-PROGRESS \\[#B\\] Fix the thing$" out)) + (should (string-match-p "^:LINEAR-ID: +uuid-1$" out)) + (should (string-match-p "^:LINEAR-IDENTIFIER: +ENG-42$" out)) + (should (string-match-p "^:LINEAR-STATE-NAME: +In Progress$" out)) + (should (string-match-p "^:LINEAR-TEAM-NAME: +Engineering$" out)) + (should (string-match-p "^:LINEAR-PROJECT-NAME: +Platform$" out)) + (should (string-match-p "^:LINEAR-ASSIGNEE-NAME: +Craig$" out)) + (should (string-match-p "^:LINEAR-LABELS: +\\[bug, backend\\]$" out)) + (should (string-match-p "^:LINEAR-DESC-SHA256: +[0-9a-f]\\{64\\}$" out)) + (should (string-match-p "^:LINEAR-TITLE-SHA256: +[0-9a-f]\\{64\\}$" out)) + (should (string-match-p "^:END:$" out))))) + +(ert-deftest test-pearl-format-issue-description-in-body-not-property () + "The description renders as body text, not a :DESCRIPTION: property." + (test-pearl--with-default-mapping + (let ((out (pearl--format-issue-as-org-entry (test-pearl--norm-full)))) + (should-not (string-match-p ":DESCRIPTION:" out)) + (should (string-match-p "Line one" out)) + (should (string-match-p "Line two" out))))) + +(ert-deftest test-pearl-format-issue-bare-empty-optionals () + "Null/missing optional fields render as empty values, and the body is empty." + (test-pearl--with-default-mapping + (let ((out (pearl--format-issue-as-org-entry (test-pearl--norm-bare)))) + (should (string-match-p "^\\*\\* TODO \\[#C\\] Bare issue$" out)) + (should (string-match-p "^:LINEAR-PROJECT-NAME: +$" out)) + (should (string-match-p "^:LINEAR-ASSIGNEE-NAME: +$" out)) + (should (string-match-p "^:LINEAR-LABELS: +\\[\\]$" out)) + ;; null description -> nothing after :END: + (should (string-match-p ":END:\n\\'" out))))) + +(ert-deftest test-pearl-format-issue-strips-brackets-from-title () + "Square brackets in the title are stripped so org parsing stays sane." + (test-pearl--with-default-mapping + (let ((out (pearl--format-issue-as-org-entry + '(:id "u" :identifier "ENG-1" :title "Fix [URGENT] bug" + :priority 1 :state (:name "Todo"))))) + (should (string-match-p "^\\*\\* TODO \\[#A\\] Fix URGENT bug$" out)) + ;; the title provenance hash is of the stripped (rendered) title, so a + ;; later no-op title sync matches the heading and never clobbers brackets + (should (string-match-p + (format "^:LINEAR-TITLE-SHA256: +%s$" (secure-hash 'sha256 "Fix URGENT bug")) + out))))) + +;;; build-org-content + +(ert-deftest test-pearl-build-org-content-empty-issues-header-only () + "With no issues the content is the file header plus the empty parent, no entries." + (test-pearl--with-default-mapping + (let ((out (pearl--build-org-content '()))) + (should (string-match-p "^#\\+title:" out)) + (should-not (string-match-p "^\\*\\* " out))))) + +(ert-deftest test-pearl-build-org-content-no-hardcoded-filetags () + "The header carries no hardcoded =#+filetags= (a personal value used to leak in)." + (test-pearl--with-default-mapping + (let ((out (pearl--build-org-content '()))) + (should-not (string-match-p "#\\+filetags" out)) + (should-not (string-match-p "twai" out))))) + +(ert-deftest test-pearl-build-org-content-renders-view-parent-heading () + "Issues nest under a single top-level heading named after the view, so they +sort together (org-sort on the parent) instead of being orphan headings." + (test-pearl--with-default-mapping + (let ((out (pearl--build-org-content + (list (test-pearl--norm-full)) + '(:type filter :name "My open issues" :filter nil)))) + (should (string-match-p "^\\* My open issues$" out)) + ;; the parent precedes the issue, which renders one level deeper + (should (< (string-match "^\\* My open issues$" out) + (string-match "^\\*\\* IN-PROGRESS" out)))))) + +(ert-deftest test-pearl-build-org-content-startup-show3levels () + "The page opens folded to headings (parent, issues, Comments), bodies hidden." + (test-pearl--with-default-mapping + (let ((out (pearl--build-org-content '()))) + (should (string-match-p "^#\\+STARTUP: show3levels$" out)) + (should-not (string-match-p "^#\\+STARTUP: overview$" out))))) + +(ert-deftest test-pearl-build-org-content-no-shared-file-id () + "The file header carries no hardcoded org :ID: drawer." + (test-pearl--with-default-mapping + (let ((out (pearl--build-org-content '()))) + (should-not (string-match-p "a12acb12" out)) + (should-not (string-match-p "^:PROPERTIES:$" out))))) + +(ert-deftest test-pearl-build-org-content-includes-each-issue () + "Each issue contributes one heading to the rendered content." + (test-pearl--with-default-mapping + (let ((out (pearl--build-org-content + (list (test-pearl--norm-full) (test-pearl--norm-bare))))) + (should (string-match-p "^\\*\\* IN-PROGRESS \\[#B\\] Fix the thing$" out)) + (should (string-match-p "^\\*\\* TODO \\[#C\\] Bare issue$" out))))) + +;;; --restore-page-visibility + +(defun test-pearl--line-visible-p (re) + "Non-nil when the line matching RE from point-min is not folded away." + (save-excursion + (goto-char (point-min)) + (and (re-search-forward re nil t) + (not (invisible-p (line-beginning-position)))))) + +(ert-deftest test-pearl-restore-page-visibility-folds-bodies-keeps-headings () + "After a repopulation the page folds to headings: parent and issues stay +visible while property drawers fold away." + (test-pearl--with-default-mapping + (let ((pearl-fold-after-update t)) + (with-temp-buffer + (insert (pearl--build-org-content (list (test-pearl--norm-full)))) + (org-mode) + (org-fold-show-all) + (pearl--restore-page-visibility) + (should (test-pearl--line-visible-p "^\\* ")) + (should (test-pearl--line-visible-p "^\\*\\* IN-PROGRESS")) + (should-not (test-pearl--line-visible-p "^:LINEAR-ID:")))))) + +(ert-deftest test-pearl-restore-page-visibility-noop-when-disabled () + "With `pearl-fold-after-update' nil the buffer is left fully expanded." + (test-pearl--with-default-mapping + (let ((pearl-fold-after-update nil)) + (with-temp-buffer + (insert (pearl--build-org-content (list (test-pearl--norm-full)))) + (org-mode) + (org-fold-show-all) + (pearl--restore-page-visibility) + (should (test-pearl--line-visible-p "^:LINEAR-ID:")))))) + +(provide 'test-pearl-format) +;;; test-pearl-format.el ends here diff --git a/tests/test-pearl-issues.el b/tests/test-pearl-issues.el new file mode 100644 index 0000000..0976e0a --- /dev/null +++ b/tests/test-pearl-issues.el @@ -0,0 +1,73 @@ +;;; test-pearl-issues.el --- Tests for pearl issue fetch/create -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for issue creation with `request' stubbed, focused on +;; `pearl--created-issue' (the success-checking helper that prevents +;; phantom "created" reports) and the create-issue async path. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) + +;;; pearl--created-issue (pure) + +(ert-deftest test-pearl-created-issue-success-returns-node () + "A successful create returns the issue node." + (let ((issue (pearl--created-issue + '((data (issueCreate (success . t) + (issue (id . "i1") (identifier . "ENG-1") (title . "T")))))))) + (should (string-equal "ENG-1" (cdr (assoc 'identifier issue)))))) + +(ert-deftest test-pearl-created-issue-soft-fail-returns-nil () + "A soft failure (success=false, issue=null) returns nil, not a phantom node." + (should (null (pearl--created-issue + '((data (issueCreate (success . :json-false) (issue)))))))) + +(ert-deftest test-pearl-created-issue-graphql-error-returns-nil () + "A GraphQL error body (no data) returns nil." + (should (null (pearl--created-issue '((errors . (((message . "bad"))))))))) + +(ert-deftest test-pearl-created-issue-empty-response-returns-nil () + "A nil/empty response returns nil." + (should (null (pearl--created-issue nil)))) + +;;; pearl-create-issue-async + +(ert-deftest test-pearl-create-issue-async-success-passes-issue () + "A successful create passes the issue node to the callback." + (let ((got 'unset)) + (testutil-linear-with-response + '((data (issueCreate (success . t) + (issue (id . "i1") (identifier . "ENG-1") (title . "T"))))) + (pearl-create-issue-async "T" "" "team" (lambda (i) (setq got i)))) + (should (string-equal "ENG-1" (cdr (assoc 'identifier got)))))) + +(ert-deftest test-pearl-create-issue-async-soft-fail-passes-nil () + "A soft failure passes nil to the callback rather than a phantom issue." + (let ((got 'unset)) + (testutil-linear-with-response + '((data (issueCreate (success . :json-false) (issue)))) + (pearl-create-issue-async "T" "" "team" (lambda (i) (setq got i)))) + (should (null got)))) + +(provide 'test-pearl-issues) +;;; test-pearl-issues.el ends here diff --git a/tests/test-pearl-mapping.el b/tests/test-pearl-mapping.el new file mode 100644 index 0000000..a4e02e7 --- /dev/null +++ b/tests/test-pearl-mapping.el @@ -0,0 +1,145 @@ +;;; test-pearl-mapping.el --- Tests for pearl mapping helpers -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Unit tests for the pure mapping helpers in pearl.el: +;; Linear state <-> org keyword, the cached TODO-states regex, and +;; Linear priority -> org cookie / readable name. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +;; A small, explicit mapping used across the state tests so cases don't +;; depend on the package default. +(defmacro test-pearl--with-mapping (mapping &rest body) + "Run BODY with the state mapping bound to MAPPING and the cache cleared." + (declare (indent 1)) + `(let ((pearl-state-to-todo-mapping ,mapping) + (pearl-todo-states-pattern nil) + (pearl--todo-states-pattern-source nil)) + ,@body)) + +;;; pearl--map-linear-state-to-org + +(ert-deftest test-pearl-map-linear-state-to-org-mapped-returns-keyword () + "A Linear state present in the mapping returns its org keyword." + (test-pearl--with-mapping '(("Todo" . "TODO") ("In Progress" . "DOING")) + (should (string-equal "DOING" (pearl--map-linear-state-to-org "In Progress"))))) + +(ert-deftest test-pearl-map-linear-state-to-org-unmapped-defaults-todo () + "An unmapped Linear state falls back to TODO." + (test-pearl--with-mapping '(("Todo" . "TODO") ("Done" . "DONE")) + (should (string-equal "TODO" (pearl--map-linear-state-to-org "Triage"))))) + +(ert-deftest test-pearl-map-linear-state-to-org-nil-defaults-todo () + "A nil state falls back to TODO rather than erroring." + (test-pearl--with-mapping '(("Todo" . "TODO")) + (should (string-equal "TODO" (pearl--map-linear-state-to-org nil))))) + +;;; pearl--map-org-state-to-linear + +(ert-deftest test-pearl-map-org-state-to-linear-mapped-returns-state () + "An org keyword present in the mapping returns its Linear state." + (test-pearl--with-mapping '(("Todo" . "TODO") ("In Progress" . "DOING")) + (should (string-equal "In Progress" (pearl--map-org-state-to-linear "DOING"))))) + +(ert-deftest test-pearl-map-org-state-to-linear-unmapped-returns-nil () + "An org keyword not in the mapping returns nil." + (test-pearl--with-mapping '(("Todo" . "TODO") ("Done" . "DONE")) + (should (null (pearl--map-org-state-to-linear "WAITING"))))) + +(ert-deftest test-pearl-map-org-state-to-linear-nil-returns-nil () + "A nil org keyword returns nil." + (test-pearl--with-mapping '(("Todo" . "TODO")) + (should (null (pearl--map-org-state-to-linear nil))))) + +;;; pearl--get-todo-states-pattern + +(ert-deftest test-pearl-get-todo-states-pattern-builds-alternation () + "The pattern is the org keywords joined with regex alternation." + (test-pearl--with-mapping '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE")) + (should (string-equal "TODO\\|IN-PROGRESS\\|DONE" + (pearl--get-todo-states-pattern))))) + +(ert-deftest test-pearl-get-todo-states-pattern-empty-mapping () + "An empty mapping yields an empty pattern string." + (test-pearl--with-mapping '() + (should (string-equal "" (pearl--get-todo-states-pattern))))) + +(ert-deftest test-pearl-get-todo-states-pattern-recomputes-after-mapping-change () + "The cached pattern is recomputed when the mapping changes mid-session. + +Regression for the stale-cache bug: a once-populated pattern must not +outlive a change to `pearl-state-to-todo-mapping'." + (test-pearl--with-mapping '(("Todo" . "TODO") ("Done" . "DONE")) + (should (string-equal "TODO\\|DONE" (pearl--get-todo-states-pattern))) + ;; Change the mapping after the pattern has been cached. + (setq pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "DOING") ("Done" . "DONE"))) + (should (string-equal "TODO\\|DOING\\|DONE" + (pearl--get-todo-states-pattern))))) + +;;; pearl--map-linear-priority-to-org + +(ert-deftest test-pearl-map-linear-priority-to-org-known-values () + "Linear priorities 1-4 map to org cookies A-D." + (should (string-equal "[#A]" (pearl--map-linear-priority-to-org 1))) + (should (string-equal "[#B]" (pearl--map-linear-priority-to-org 2))) + (should (string-equal "[#C]" (pearl--map-linear-priority-to-org 3))) + (should (string-equal "[#D]" (pearl--map-linear-priority-to-org 4)))) + +(ert-deftest test-pearl-map-linear-priority-to-org-zero-defaults-c () + "Priority 0 (No priority) falls back to [#C]." + (should (string-equal "[#C]" (pearl--map-linear-priority-to-org 0)))) + +(ert-deftest test-pearl-map-linear-priority-to-org-nil-and-unknown-default-c () + "A nil or out-of-range priority falls back to [#C]." + (should (string-equal "[#C]" (pearl--map-linear-priority-to-org nil))) + (should (string-equal "[#C]" (pearl--map-linear-priority-to-org 99)))) + +;;; pearl--get-linear-priority-name + +(ert-deftest test-pearl-get-linear-priority-name-known-values () + "Linear priorities 1-4 have readable names." + (should (string-equal "Urgent" (pearl--get-linear-priority-name 1))) + (should (string-equal "High" (pearl--get-linear-priority-name 2))) + (should (string-equal "Medium" (pearl--get-linear-priority-name 3))) + (should (string-equal "Low" (pearl--get-linear-priority-name 4)))) + +(ert-deftest test-pearl-get-linear-priority-name-nil-and-unknown-default-medium () + "A nil, zero, or out-of-range priority falls back to Medium." + (should (string-equal "Medium" (pearl--get-linear-priority-name 0))) + (should (string-equal "Medium" (pearl--get-linear-priority-name nil))) + (should (string-equal "Medium" (pearl--get-linear-priority-name 99)))) + +;;; pearl-get-priorities + +(ert-deftest test-pearl-get-priorities-returns-fixed-alist () + "The priority list maps the five Linear priority names to their integers." + (let ((priorities (pearl-get-priorities))) + (should (equal 0 (cdr (assoc "No priority" priorities)))) + (should (equal 1 (cdr (assoc "Urgent" priorities)))) + (should (equal 2 (cdr (assoc "High" priorities)))) + (should (equal 3 (cdr (assoc "Medium" priorities)))) + (should (equal 4 (cdr (assoc "Low" priorities)))))) + +(provide 'test-pearl-mapping) +;;; test-pearl-mapping.el ends here diff --git a/tests/test-pearl-menu.el b/tests/test-pearl-menu.el new file mode 100644 index 0000000..1362b2e --- /dev/null +++ b/tests/test-pearl-menu.el @@ -0,0 +1,73 @@ +;;; test-pearl-menu.el --- Tests for the transient menu -*- lexical-binding: t; -*- + +;;; Commentary: +;; Tests for `pearl-menu', the transient dispatcher. The menu is +;; interactive UI, so these test the integration -- the prefix is a real +;; command, every suffix dispatches to a bound command, and the key bindings +;; don't collide -- rather than transient's own rendering behavior. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el" + (file-name-directory + (or load-file-name buffer-file-name)))) +(require 'transient) + +(defun test-pearl-menu--suffixes (node) + "Collect (KEY . COMMAND) pairs from a transient layout NODE. +Walks vectors and lists recursively; whenever it reaches a plist +\(a list whose car is a keyword) it reads :key and :command from it." + (cond + ((vectorp node) + (apply #'append (mapcar #'test-pearl-menu--suffixes + (append node nil)))) + ((and (consp node) (keywordp (car node))) + (let ((cmd (plist-get node :command)) + (key (plist-get node :key))) + (when cmd (list (cons key cmd))))) + ((consp node) + (apply #'append (mapcar #'test-pearl-menu--suffixes node))) + (t nil))) + +(defun test-pearl-menu--pairs () + "Return the (KEY . COMMAND) pairs declared in `pearl-menu'." + (test-pearl-menu--suffixes + (get 'pearl-menu 'transient--layout))) + +(ert-deftest test-pearl-menu-is-command () + "The dispatcher is defined and is an interactive command." + (should (fboundp 'pearl-menu)) + (should (commandp 'pearl-menu))) + +(ert-deftest test-pearl-menu-suffixes-dispatch-to-real-commands () + "Every suffix in the menu names a bound, interactive command. +This is the regression guard: rename or remove a command and the +menu entry that still points at it fails here." + (let ((pairs (test-pearl-menu--pairs))) + (should pairs) + (dolist (pair pairs) + (let ((cmd (cdr pair))) + (should (fboundp cmd)) + (should (commandp cmd)))))) + +(ert-deftest test-pearl-menu-keys-are-unique () + "No two suffixes share a key binding." + (let* ((pairs (test-pearl-menu--pairs)) + (keys (delq nil (mapcar #'car pairs)))) + (should (= (length keys) (length (delete-dups (copy-sequence keys))))))) + +(ert-deftest test-pearl-menu-covers-core-commands () + "A representative slice of the command surface is reachable from the menu." + (let ((cmds (mapcar #'cdr (test-pearl-menu--pairs)))) + (dolist (expected '(pearl-list-issues + pearl-run-view + pearl-run-saved-query + pearl-sync-current-issue + pearl-set-state + pearl-add-comment + pearl-new-issue + pearl-delete-current-issue)) + (should (memq expected cmds))))) + +(provide 'test-pearl-menu) +;;; test-pearl-menu.el ends here diff --git a/tests/test-pearl-merge.el b/tests/test-pearl-merge.el new file mode 100644 index 0000000..180539e --- /dev/null +++ b/tests/test-pearl-merge.el @@ -0,0 +1,252 @@ +;;; test-pearl-merge.el --- Tests for merge-by-LINEAR-ID refresh -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the same-source refresh merge: `pearl--merge-issues-into-buffer' +;; updates existing issue subtrees in place by LINEAR-ID, appends new matches, +;; drops issues gone from the result, and protects unpushed local edits (it +;; neither overwrites nor drops a subtree whose body diverges from its stored +;; provenance hash). Also covers the header refresh and the `--merge-query-result' +;; render boundary that drives `pearl-refresh-current-view'. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl-merge--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT, default mapping bound." + (declare (indent 1)) + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE"))) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +(defun test-pearl-merge--issue (id title desc) + "A normalized issue plist with ID, TITLE, and DESC for merge input." + (list :id id :identifier (concat "ENG-" id) :title title :description desc + :priority 2 :url (concat "https://linear.app/x/" id) + :updated-at "2026-05-23T03:00:00.000Z" + :state (list :id "s1" :name "Todo" :type "unstarted") + :team (list :id "t1" :key "ENG" :name "Engineering"))) + +(defun test-pearl-merge--raw (id title desc) + "A raw issue node (json-read shape) with ID, TITLE, and DESC." + `((id . ,id) (identifier . ,(concat "ENG-" id)) (title . ,title) + (description . ,desc) (priority . 2) (url . ,(concat "https://linear.app/x/" id)) + (updatedAt . "2026-05-23T03:00:00.000Z") + (state (id . "s1") (name . "Todo") (type . "unstarted")) + (team (id . "t1") (key . "ENG") (name . "Engineering")) + (labels (nodes . [])))) + +(defun test-pearl-merge--buffer (&rest issues) + "A header plus the formatted ISSUES, as the active file would hold them." + (concat "#+title: Linear — My open issues\n" + "#+LINEAR-SOURCE: (:type filter :name \"My open issues\" :filter (:assignee :me))\n" + "#+LINEAR-RUN-AT: 2026-05-01 09:00\n" + "#+LINEAR-COUNT: 9\n" + "#+LINEAR-TRUNCATED: no\n\n" + (mapconcat #'pearl--format-issue-as-org-entry issues ""))) + +;;; --merge-issues-into-buffer + +(ert-deftest test-pearl-merge-updates-existing-in-place () + "An existing issue still in the result is re-rendered from the fetch in place." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.") + (test-pearl-merge--issue "b" "Beta" "Desc Beta.")) + (let ((counts (pearl--merge-issues-into-buffer + (list (test-pearl-merge--issue "a" "Alpha Renamed" "Desc Alpha.") + (test-pearl-merge--issue "b" "Beta" "Desc Beta."))))) + (should (= 2 (plist-get counts :updated))) + (should (= 0 (plist-get counts :added))) + (should (= 0 (plist-get counts :dropped))) + (should (= 0 (plist-get counts :skipped))) + (goto-char (point-min)) + (should (re-search-forward "Alpha Renamed" nil t)) + (should-not (save-excursion (re-search-forward "^\\*\\*\\* .*Alpha$" nil t))) + ;; Alpha still precedes Beta — order is stable. + (goto-char (point-min)) + (let ((a (progn (re-search-forward "Alpha Renamed") (point))) + (b (progn (re-search-forward "Beta") (point)))) + (should (< a b)))))) + +(ert-deftest test-pearl-merge-appends-new-issue () + "An issue new to the result is appended after the existing ones." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.")) + (let ((counts (pearl--merge-issues-into-buffer + (list (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.") + (test-pearl-merge--issue "b" "Beta" "Desc Beta."))))) + (should (= 1 (plist-get counts :added))) + (goto-char (point-min)) + (should (string= "a" (progn (re-search-forward "LINEAR-ID: *\\(.*\\)$") (match-string 1)))) + (should (re-search-forward "LINEAR-ID: *b" nil t)) + (goto-char (point-min)) + (should (< (progn (re-search-forward "Alpha") (point)) + (progn (re-search-forward "Beta") (point))))))) + +(ert-deftest test-pearl-merge-drops-absent-issue () + "A clean issue no longer in the result is dropped." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.") + (test-pearl-merge--issue "b" "Beta" "Desc Beta.")) + (let ((counts (pearl--merge-issues-into-buffer + (list (test-pearl-merge--issue "a" "Alpha" "Desc Alpha."))))) + (should (= 1 (plist-get counts :dropped))) + (goto-char (point-min)) + (should (re-search-forward "Alpha" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "Beta" nil t))))) + +(ert-deftest test-pearl-merge-keeps-unpushed-edit-on-update () + "An existing subtree with unpushed body edits is kept, not overwritten." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.")) + ;; Dirty the body so its hash no longer matches the stored provenance. + (goto-char (point-min)) + (re-search-forward "Desc Alpha\\.") + (end-of-line) + (insert " UNPUSHED EDIT") + (let ((counts (pearl--merge-issues-into-buffer + (list (test-pearl-merge--issue "a" "Alpha Renamed" "Remote desc."))))) + (should (= 1 (plist-get counts :skipped))) + (should (= 0 (plist-get counts :updated))) + (goto-char (point-min)) + ;; Local edit and old heading survive; the remote rename did not land. + (should (re-search-forward "UNPUSHED EDIT" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "Alpha Renamed" nil t))))) + +(ert-deftest test-pearl-merge-keeps-dirty-issue-absent-from-result () + "A dirty issue gone from the result is kept rather than dropped (no data loss)." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.") + (test-pearl-merge--issue "b" "Beta" "Desc Beta.")) + (goto-char (point-min)) + (re-search-forward "Desc Alpha\\.") + (end-of-line) + (insert " UNPUSHED EDIT") + (let ((counts (pearl--merge-issues-into-buffer + (list (test-pearl-merge--issue "b" "Beta" "Desc Beta."))))) + (should (= 1 (plist-get counts :skipped))) + (should (= 0 (plist-get counts :dropped))) + (goto-char (point-min)) + (should (re-search-forward "UNPUSHED EDIT" nil t))))) + +(ert-deftest test-pearl-merge-updates-rich-description-issue-in-place () + "An unedited issue with lossy markdown (a heading) is updated, not skipped. +Regression: the dirty check round-tripped Org back to markdown and mistook a +lossy round-trip (# heading -> bold, *italic* -> **bold**) for a local edit, so +refresh silently skipped every rich-text issue." + (test-pearl-merge--in-org + (test-pearl-merge--buffer + (test-pearl-merge--issue "a" "Alpha" "# Heading\n\nSome body text.")) + (let ((counts (pearl--merge-issues-into-buffer + (list (test-pearl-merge--issue "a" "Alpha Renamed" + "# Heading\n\nSome body text."))))) + (should (= 1 (plist-get counts :updated))) + (should (= 0 (plist-get counts :skipped))) + (goto-char (point-min)) + (should (re-search-forward "Alpha Renamed" nil t))))) + +(ert-deftest test-pearl-subtree-dirty-p-rich-description-unedited-not-dirty () + "A freshly rendered subtree with lossy-markdown description is not dirty unedited." + (test-pearl-merge--in-org + (test-pearl-merge--buffer + (test-pearl-merge--issue "a" "Alpha" "# Heading\n\nSome body text.")) + (goto-char (point-min)) + (re-search-forward "^\\*\\* ") + (beginning-of-line) + (should-not (pearl--subtree-dirty-p)))) + +(ert-deftest test-pearl-subtree-dirty-p-empty-description-not-dirty () + "An issue with an empty description is not dirty. +Regression: body extraction overshot an empty body into the next issue's +subtree, so every description-less issue read as a local edit." + (test-pearl-merge--in-org + (test-pearl-merge--buffer + (test-pearl-merge--issue "a" "Alpha" "") + (test-pearl-merge--issue "b" "Beta" "Desc Beta.")) + (goto-char (point-min)) + (re-search-forward "^\\*\\* ") + (beginning-of-line) + (should (string= "" (pearl--issue-body-at-point))) + (should-not (pearl--subtree-dirty-p)))) + +(ert-deftest test-pearl-subtree-dirty-p-edited-body-is-dirty () + "Editing the rendered body still marks the subtree dirty (edit detection holds)." + (test-pearl-merge--in-org + (test-pearl-merge--buffer + (test-pearl-merge--issue "a" "Alpha" "# Heading\n\nSome body text.")) + (goto-char (point-min)) + (re-search-forward "Some body text\\.") + (end-of-line) + (insert " LOCAL EDIT") + (goto-char (point-min)) + (re-search-forward "^\\*\\* ") + (beginning-of-line) + (should (pearl--subtree-dirty-p)))) + +;;; --update-source-header + +(ert-deftest test-pearl-merge-update-source-header-rewrites-count () + "The header refresh updates the count and truncation lines in place." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.")) + (pearl--update-source-header 5 t) + (goto-char (point-min)) + (should (re-search-forward "^#\\+LINEAR-COUNT: 5$" nil t)) + (goto-char (point-min)) + (should (re-search-forward "^#\\+LINEAR-TRUNCATED: yes$" nil t)))) + +;;; --merge-query-result (render boundary) + +(ert-deftest test-pearl-merge-query-result-merges-and-updates-header () + "An ok result normalizes its raw nodes, merges them, and refreshes the count." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.")) + (let ((source '(:type filter :name "My open issues" :filter (:assignee :me))) + (result (pearl--make-query-result + 'ok :issues (list (test-pearl-merge--raw "a" "Alpha Renamed" "Desc Alpha.") + (test-pearl-merge--raw "c" "Gamma" "Desc Gamma."))))) + (pearl--merge-query-result result source) + (goto-char (point-min)) + (should (re-search-forward "Alpha Renamed" nil t)) + (should (re-search-forward "Gamma" nil t)) + (goto-char (point-min)) + (should (re-search-forward "^#\\+LINEAR-COUNT: 2$" nil t))))) + +(ert-deftest test-pearl-merge-query-result-empty-leaves-buffer () + "An empty result leaves the buffer unchanged rather than dropping everything." + (test-pearl-merge--in-org + (test-pearl-merge--buffer (test-pearl-merge--issue "a" "Alpha" "Desc Alpha.")) + (let ((source '(:type filter :name "My open issues" :filter (:assignee :me))) + (before (buffer-string))) + (pearl--merge-query-result (pearl--make-query-result 'empty) source) + (should (string= before (buffer-string)))))) + +(provide 'test-pearl-merge) +;;; test-pearl-merge.el ends here diff --git a/tests/test-pearl-normalize.el b/tests/test-pearl-normalize.el new file mode 100644 index 0000000..78874ab --- /dev/null +++ b/tests/test-pearl-normalize.el @@ -0,0 +1,138 @@ +;;; test-pearl-normalize.el --- Tests for API model normalization -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the normalizers that flatten raw json-read Linear responses into +;; internal plists. Driven by the shared fixtures so the renderer-facing +;; contract is locked: vectors become lists, absent/`:json-false' fields become +;; nil, and a null comment author falls back to the bot/external actor. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-fixtures (expand-file-name "testutil-fixtures.el")) + +;;; node-list + +(ert-deftest test-pearl-normalize-node-list-vector-to-list () + "A connection's nodes vector is returned as a list." + (should (equal '(1 2 3) (pearl--node-list '((nodes . [1 2 3])))))) + +(ert-deftest test-pearl-normalize-node-list-empty-and-missing () + "An empty or missing nodes connection yields an empty list." + (should (null (pearl--node-list '((nodes . []))))) + (should (null (pearl--node-list '((pageInfo . nil)))))) + +;;; normalize-issue -- fully populated + +(ert-deftest test-pearl-normalize-issue-full () + "A full issue normalizes every field, flattening nested objects." + (let ((i (pearl--normalize-issue (testutil-linear-fixture-issue-full)))) + (should (string= "ENG-42" (plist-get i :identifier))) + (should (string= "Fix the thing" (plist-get i :title))) + (should (= 2 (plist-get i :priority))) + (should (string= "In Progress" (plist-get (plist-get i :state) :name))) + (should (string= "started" (plist-get (plist-get i :state) :type))) + (should (string= "Craig" (plist-get (plist-get i :assignee) :name))) + (should (string= "ENG" (plist-get (plist-get i :team) :key))) + (should (string= "Platform" (plist-get (plist-get i :project) :name))) + (should (string= "Cycle 12" (plist-get (plist-get i :cycle) :name))) + ;; labels: vector of nodes -> list of (:id :name) plists + (should (equal '("bug" "backend") + (mapcar (lambda (l) (plist-get l :name)) (plist-get i :labels)))))) + +;;; normalize-issue -- null / missing optional fields + +(ert-deftest test-pearl-normalize-issue-null-fields () + "Absent or null optional fields normalize to nil, not an error." + (let ((i (pearl--normalize-issue (testutil-linear-fixture-issue-null-fields)))) + (should (string= "ENG-7" (plist-get i :identifier))) + (should (null (plist-get i :description))) + (should (null (plist-get i :assignee))) + (should (null (plist-get i :project))) + (should (null (plist-get i :cycle))) + (should (null (plist-get i :labels))) + ;; state is still present + (should (string= "Todo" (plist-get (plist-get i :state) :name))))) + +(ert-deftest test-pearl-normalize-issue-nil-input () + "Normalizing nil yields nil." + (should (null (pearl--normalize-issue nil)))) + +(ert-deftest test-pearl-normalize-issue-omits-comments-when-absent () + "An issue fetched without comments has a nil :comments, not an empty list." + (let ((i (pearl--normalize-issue (testutil-linear-fixture-issue-full)))) + (should (null (plist-get i :comments))))) + +;;; normalize-comment -- author fallback + +(ert-deftest test-pearl-normalize-comment-user-author () + "A comment with a user takes the user's name as author." + (let* ((raw (car (pearl--node-list + (cdr (assoc 'comments (testutil-linear-fixture-issue-with-comments)))))) + (c (pearl--normalize-comment raw))) + (should (string= "Alice" (plist-get c :author))) + (should (string= "First comment" (plist-get c :body))))) + +(ert-deftest test-pearl-normalize-comment-null-user-falls-back-to-bot () + "A comment with a null user falls back to the bot actor's name. + +`Comment.user' is null for integration/bot comments, so the renderer must not +assume a user is present." + (let ((c (pearl--normalize-comment + '((id . "cm-bot") (body . "Deployed") (createdAt . "2026-05-20T00:00:00Z") + (user) (botActor . ((name . "GitHub"))))))) + (should (string= "GitHub" (plist-get c :author))))) + +(ert-deftest test-pearl-normalize-comment-null-user-no-actor-nil () + "A null user with no bot or external actor leaves :author nil. +The renderer is responsible for showing a placeholder; the normalizer reports +the absence honestly rather than inventing a name." + (let ((c (pearl--normalize-comment '((id . "cm-x") (body . "x") (user))))) + (should (null (plist-get c :author))))) + +(ert-deftest test-pearl-normalize-comment-bot-without-name-default () + "A bot actor with no name falls back to the literal \"automation\"." + (let ((c (pearl--normalize-comment + '((id . "cm-b") (body . "x") (user) (botActor . ((id . "b1"))))))) + (should (string= "automation" (plist-get c :author))))) + +;;; normalize-custom-view + +(ert-deftest test-pearl-normalize-custom-view-personal () + "A personal (shared=false) workspace-wide view: :shared nil, :team nil." + (let* ((views (cdr (assoc 'nodes (assoc 'customViews + (assoc 'data (testutil-linear-fixture-custom-views)))))) + (cv (pearl--normalize-custom-view (elt views 0)))) + (should (string= "My open work" (plist-get cv :name))) + (should (null (plist-get cv :shared))) + (should (null (plist-get cv :team))) + (should (string= "Craig" (plist-get (plist-get cv :owner) :name))))) + +(ert-deftest test-pearl-normalize-custom-view-shared-with-team () + "A shared team view: :shared t and a normalized :team plist." + (let* ((views (cdr (assoc 'nodes (assoc 'customViews + (assoc 'data (testutil-linear-fixture-custom-views)))))) + (cv (pearl--normalize-custom-view (elt views 1)))) + (should (eq t (plist-get cv :shared))) + (should (string= "ENG" (plist-get (plist-get cv :team) :key))))) + +(provide 'test-pearl-normalize) +;;; test-pearl-normalize.el ends here diff --git a/tests/test-pearl-open.el b/tests/test-pearl-open.el new file mode 100644 index 0000000..1be6114 --- /dev/null +++ b/tests/test-pearl-open.el @@ -0,0 +1,66 @@ +;;; test-pearl-open.el --- Tests for open-issue-in-browser -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for `pearl-open-current-issue', which opens the issue at point +;; in the browser from its LINEAR-URL property. `browse-url' is stubbed. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT at point-min." + (declare (indent 1)) + `(with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body)) + +(ert-deftest test-pearl-open-current-issue-visits-url () + "The command passes the heading's LINEAR-URL to `browse-url'." + (let ((visited nil)) + (test-pearl--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-URL: https://linear.app/x/ENG-1\n:END:\nbody\n" + (cl-letf (((symbol-function 'browse-url) + (lambda (url &rest _) (setq visited url)))) + (goto-char (point-max)) + (pearl-open-current-issue) + (should (string= "https://linear.app/x/ENG-1" visited)))))) + +(ert-deftest test-pearl-open-current-issue-no-url-errors () + "An issue heading without a LINEAR-URL signals a user error, no browse." + (let ((visited nil)) + (test-pearl--in-org + "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (cl-letf (((symbol-function 'browse-url) + (lambda (url &rest _) (setq visited url)))) + (should-error (pearl-open-current-issue) :type 'user-error) + (should-not visited))))) + +(ert-deftest test-pearl-open-current-issue-not-on-issue-errors () + "Running outside a heading signals a user error." + (test-pearl--in-org "plain text, no heading\n" + (should-error (pearl-open-current-issue) :type 'user-error))) + +(provide 'test-pearl-open) +;;; test-pearl-open.el ends here diff --git a/tests/test-pearl-org-parse.el b/tests/test-pearl-org-parse.el new file mode 100644 index 0000000..87f4a02 --- /dev/null +++ b/tests/test-pearl-org-parse.el @@ -0,0 +1,152 @@ +;;; test-pearl-org-parse.el --- Tests for pearl org parsing -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the org readers `pearl--extract-org-heading-properties' and +;; `pearl--process-heading-at-point'. The reader uses org APIs over the +;; LINEAR-* property drawer, so it works from anywhere in the entry, at any +;; heading depth, and is unbothered by body text or nested sub-entries. The one +;; network boundary reached during processing (`--update-issue-state-async') is +;; stubbed. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT, default mapping bound." + (declare (indent 1)) + ;; Declare the Linear keywords so `org-get-todo-state' recognizes them, the + ;; way the generated file's `#+TODO:' line does in real use. + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE"))) + (pearl-todo-states-pattern nil) + (pearl--todo-states-pattern-source nil) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +;;; extract-org-heading-properties + +(ert-deftest test-pearl-extract-heading-properties-full () + "A complete Linear entry yields the todo keyword, ids, and team id." + (test-pearl--in-org + "*** TODO My issue\n:PROPERTIES:\n:LINEAR-ID: abc-123\n:LINEAR-IDENTIFIER: ENG-5\n:LINEAR-TEAM-ID: team-9\n:END:\n" + (re-search-forward "My issue") + (let ((props (pearl--extract-org-heading-properties))) + (should (string-equal "TODO" (plist-get props :todo-state))) + (should (string-equal "abc-123" (plist-get props :issue-id))) + (should (string-equal "ENG-5" (plist-get props :issue-identifier))) + (should (string-equal "team-9" (plist-get props :team-id)))))) + +(ert-deftest test-pearl-extract-reads-from-inside-the-entry () + "The reader works with point in the body, not only on the heading line." + (test-pearl--in-org + "*** TODO My issue\n:PROPERTIES:\n:LINEAR-ID: abc\n:END:\nsome body text here\n" + (goto-char (point-max)) + (should (string-equal "abc" (plist-get (pearl--extract-org-heading-properties) :issue-id))))) + +(ert-deftest test-pearl-extract-team-id-is-read-not-looked-up () + "The team id comes straight from LINEAR-TEAM-ID, with no network call." + (cl-letf (((symbol-function 'pearl--get-team-id-by-name) + (lambda (&rest _) (error "should not be called")))) + (test-pearl--in-org + "*** TODO x\n:PROPERTIES:\n:LINEAR-ID: i\n:LINEAR-TEAM-ID: t-1\n:END:\n" + (re-search-forward "x") + (should (string-equal "t-1" (plist-get (pearl--extract-org-heading-properties) :team-id)))))) + +(ert-deftest test-pearl-extract-missing-id () + "A drawer with no LINEAR-ID yields a nil issue-id." + (test-pearl--in-org + "*** TODO x\n:PROPERTIES:\n:LINEAR-IDENTIFIER: ENG-9\n:END:\n" + (re-search-forward "x") + (let ((props (pearl--extract-org-heading-properties))) + (should (string-equal "TODO" (plist-get props :todo-state))) + (should (null (plist-get props :issue-id))) + (should (string-equal "ENG-9" (plist-get props :issue-identifier)))))) + +(ert-deftest test-pearl-extract-deeper-heading-now-supported () + "A level-4 entry is read the same as level-3 (the reader is depth-agnostic)." + (test-pearl--in-org + "*** TODO parent\n**** TODO child\n:PROPERTIES:\n:LINEAR-ID: c\n:END:\n" + (re-search-forward "child") + (should (string-equal "c" (plist-get (pearl--extract-org-heading-properties) :issue-id))))) + +(ert-deftest test-pearl-extract-off-heading-nil () + "Before the first heading, nothing is extracted." + (test-pearl--in-org + "preamble line\n* Top\n" + (goto-char (point-min)) + (should (null (pearl--extract-org-heading-properties))))) + +;;; process-heading-at-point + +(ert-deftest test-pearl-process-heading-updates-when-complete () + "A complete entry triggers an async state update with the mapped state." + (let ((captured nil)) + (cl-letf (((symbol-function 'pearl--update-issue-state-async) + (lambda (id state team) (setq captured (list id state team))))) + (test-pearl--in-org + "*** IN-PROGRESS x\n:PROPERTIES:\n:LINEAR-ID: i-1\n:LINEAR-IDENTIFIER: ENG-2\n:LINEAR-TEAM-ID: t-1\n:END:\n" + (re-search-forward "x") + (pearl--process-heading-at-point) + (should (equal '("i-1" "In Progress" "t-1") captured)))))) + +(ert-deftest test-pearl-process-heading-skips-without-team () + "An entry missing its team id makes no API call." + (let ((called nil)) + (cl-letf (((symbol-function 'pearl--update-issue-state-async) + (lambda (&rest _) (setq called t)))) + (test-pearl--in-org + "*** TODO x\n:PROPERTIES:\n:LINEAR-ID: i-1\n:LINEAR-IDENTIFIER: ENG-2\n:END:\n" + (re-search-forward "x") + (pearl--process-heading-at-point) + (should-not called))))) + +;;; render -> parse round trip + +(ert-deftest test-pearl-render-parse-round-trip () + "An issue rendered by build-org-content parses back through the reader. +Locks the render/parse contract: the LINEAR-* drawer the renderer writes is +exactly what the reader extracts, and the rendered keyword is recognized." + (let ((pearl-state-to-todo-mapping '(("In Progress" . "IN-PROGRESS"))) + (pearl-todo-states-pattern nil) + (pearl--todo-states-pattern-source nil) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (let ((content (pearl--build-org-content + '((:id "i-1" :identifier "ENG-2" :title "round trip" + :priority 2 :state (:name "In Progress") :team (:id "t-1")))))) + (with-temp-buffer + (insert content) + (org-mode) + (goto-char (point-min)) + (re-search-forward "round trip") + (let ((props (pearl--extract-org-heading-properties))) + (should (string-equal "i-1" (plist-get props :issue-id))) + (should (string-equal "ENG-2" (plist-get props :issue-identifier))) + (should (string-equal "IN-PROGRESS" (plist-get props :todo-state))) + (should (string-equal "t-1" (plist-get props :team-id)))))))) + +(provide 'test-pearl-org-parse) +;;; test-pearl-org-parse.el ends here diff --git a/tests/test-pearl-org-write.el b/tests/test-pearl-org-write.el new file mode 100644 index 0000000..c253190 --- /dev/null +++ b/tests/test-pearl-org-write.el @@ -0,0 +1,85 @@ +;;; test-pearl-org-write.el --- Tests for pearl org file write-back -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for `pearl--update-org-from-issues', the buffer-aware +;; write-back. Uses real temp files (file I/O is the behavior under test); +;; the three branches are no-buffer, clean-buffer, and dirty-buffer. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +(defvar test-pearl--sample-issues + '((:id "u" :identifier "ENG-1" :title "T" :priority 3 :state (:name "Todo"))) + "One normalized issue, enough to render a recognizable org entry.") + +(defmacro test-pearl--with-org-file (var &rest body) + "Bind VAR to a fresh temp .org path and run BODY, cleaning up after. +The state mapping is bound so rendering is deterministic." + (declare (indent 1)) + `(let* ((,var (make-temp-file "linear-test-" nil ".org")) + (pearl-org-file-path ,var) + (pearl-state-to-todo-mapping '(("Todo" . "TODO")))) + (unwind-protect + (progn ,@body) + (let ((b (find-buffer-visiting ,var))) + (when b + (with-current-buffer b (set-buffer-modified-p nil)) + (kill-buffer b))) + (when (file-exists-p ,var) (delete-file ,var))))) + +(ert-deftest test-pearl-update-org-no-buffer-writes-file () + "With no buffer visiting the file, issues are written to disk." + (test-pearl--with-org-file tmp + (let ((b (find-buffer-visiting tmp))) (when b (kill-buffer b))) + (pearl--update-org-from-issues test-pearl--sample-issues) + (let ((content (with-temp-buffer (insert-file-contents tmp) (buffer-string)))) + (should (string-match-p "#\\+title: Linear" content)) + (should (string-match-p "#\\+LINEAR-SOURCE: " content)) + (should (string-match-p "\\*\\* TODO \\[#C\\] T" content))))) + +(ert-deftest test-pearl-update-org-clean-buffer-replaces-contents () + "A clean visiting buffer is replaced in place and saved." + (test-pearl--with-org-file tmp + (let ((buf (find-file-noselect tmp))) + (with-current-buffer buf + (insert "old content") + (save-buffer)) + (pearl--update-org-from-issues test-pearl--sample-issues) + (with-current-buffer buf + (should-not (buffer-modified-p)) + (should (string-match-p "\\*\\* TODO \\[#C\\] T" (buffer-string))) + (should-not (string-match-p "old content" (buffer-string))))))) + +(ert-deftest test-pearl-update-org-dirty-buffer-not-overwritten () + "A buffer with unsaved edits is left untouched, not clobbered." + (test-pearl--with-org-file tmp + (let ((buf (find-file-noselect tmp))) + (with-current-buffer buf + (insert "unsaved edits")) + (pearl--update-org-from-issues test-pearl--sample-issues) + (with-current-buffer buf + (should (buffer-modified-p)) + (should (string-match-p "unsaved edits" (buffer-string))) + (should-not (string-match-p "ENG-1" (buffer-string))))))) + +(provide 'test-pearl-org-write) +;;; test-pearl-org-write.el ends here diff --git a/tests/test-pearl-output.el b/tests/test-pearl-output.el new file mode 100644 index 0000000..79b7a82 --- /dev/null +++ b/tests/test-pearl-output.el @@ -0,0 +1,145 @@ +;;; test-pearl-output.el --- Tests for the active-file output model -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the active-file output model: the filter summary, the +;; source-tracking header (with the affordance preamble) written by +;; `--build-org-content', reading the active source back from a buffer, and +;; `pearl-refresh-current-view' re-running the recorded source. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +;;; --summarize-filter + +(ert-deftest test-pearl-summarize-filter-fields () + "A filter plist summarizes its set dimensions in a readable string." + (let ((s (pearl--summarize-filter '(:assignee :me :open t :state "In Progress")))) + (should (string-match-p "assignee" s)) + (should (string-match-p "open" s)) + (should (string-match-p "In Progress" s)))) + +(ert-deftest test-pearl-summarize-filter-empty () + "An empty filter summarizes as all issues." + (should (string-match-p "all" (pearl--summarize-filter nil)))) + +;;; --build-org-content with a source + +(ert-deftest test-pearl-build-org-content-source-header () + "With a source, the header carries the title, serialized source, and count." + (let* ((source '(:type filter :name "My open issues" :filter (:assignee :me :open t))) + (out (pearl--build-org-content '() source))) + (should (string-match-p "^#\\+title: Linear — My open issues$" out)) + (should (string-match-p "^#\\+LINEAR-SOURCE: " out)) + (should (string-match-p "^#\\+LINEAR-COUNT: 0$" out)) + ;; affordance preamble is present as org comments, not content + (should (string-match-p "^# .*pearl-sync-current-issue" out)))) + +(ert-deftest test-pearl-build-org-content-source-roundtrips () + "The serialized source in the header reads back to the original plist." + (let* ((source '(:type filter :name "Bugs" :filter (:labels ("bug") :open t))) + (out (pearl--build-org-content '() source))) + (with-temp-buffer + (insert out) + (should (equal source (pearl--read-active-source)))))) + +(ert-deftest test-pearl-build-org-content-default-source-back-compat () + "Called with no source, the content still has a title and no entries." + (let ((out (pearl--build-org-content '()))) + (should (string-match-p "^#\\+title:" out)) + (should-not (string-match-p "^\\*\\*\\* " out)))) + +;;; --read-active-source + +(ert-deftest test-pearl-read-active-source-absent () + "A buffer with no source header reads back nil." + (with-temp-buffer + (insert "#+title: something\n\n* a heading\n") + (should-not (pearl--read-active-source)))) + +;;; refresh-current-view + +(ert-deftest test-pearl-refresh-current-view-reruns-source () + "Refresh reads the recorded filter source and merges the re-run result." + (let ((ran nil) (merged-source nil) + (source '(:type filter :name "My open issues" :filter (:assignee :me :open t)))) + (with-temp-buffer + (insert (format "#+title: Linear — My open issues\n#+LINEAR-SOURCE: %s\n\n" + (prin1-to-string source))) + (org-mode) + (cl-letf (((symbol-function 'pearl--query-issues-async) + (lambda (_filter cb) + (setq ran t) + (funcall cb (pearl--make-query-result 'ok :issues nil)))) + ((symbol-function 'pearl--merge-query-result) + (lambda (_result src) (setq merged-source src)))) + (pearl-refresh-current-view) + (should ran) + (should (equal source merged-source)))))) + +(ert-deftest test-pearl-refresh-current-view-no-source-errors () + "Refresh with no recorded source signals a user error." + (with-temp-buffer + (insert "#+title: plain\n") + (org-mode) + (should-error (pearl-refresh-current-view) :type 'user-error))) + +;;; --update-org-from-issues surfaces the result + +(ert-deftest test-pearl-update-org-surfaces-fresh-buffer () + "With no buffer visiting the file, the write creates one and surfaces it." + (let* ((tmp (make-temp-file "pearl-out" nil ".org")) + (pearl-org-file-path tmp) + (surfaced nil)) + (unwind-protect + (progn + (when (find-buffer-visiting tmp) (kill-buffer (find-buffer-visiting tmp))) + (cl-letf (((symbol-function 'pearl--surface-buffer) + (lambda (b) (setq surfaced b)))) + (pearl--update-org-from-issues '() '(:type filter :name "X" :filter nil) nil)) + (should (bufferp surfaced)) + (should (buffer-live-p surfaced)) + (should (string= (file-truename tmp) + (file-truename (buffer-file-name surfaced))))) + (when (find-buffer-visiting tmp) (kill-buffer (find-buffer-visiting tmp))) + (ignore-errors (delete-file tmp))))) + +(ert-deftest test-pearl-update-org-surfaces-existing-buffer () + "With a clean buffer visiting the file, the update surfaces that buffer." + (let* ((tmp (make-temp-file "pearl-out" nil ".org")) + (pearl-org-file-path tmp) + (surfaced nil) + (buf (find-file-noselect tmp))) + (unwind-protect + (progn + (with-current-buffer buf (set-buffer-modified-p nil)) + (cl-letf (((symbol-function 'pearl--surface-buffer) + (lambda (b) (setq surfaced b)))) + (pearl--update-org-from-issues '() '(:type filter :name "X" :filter nil) nil)) + (should (eq surfaced buf))) + (when (buffer-live-p buf) + (with-current-buffer buf (set-buffer-modified-p nil)) + (kill-buffer buf)) + (ignore-errors (delete-file tmp))))) + +(provide 'test-pearl-output) +;;; test-pearl-output.el ends here diff --git a/tests/test-pearl-query.el b/tests/test-pearl-query.el new file mode 100644 index 0000000..87e48b9 --- /dev/null +++ b/tests/test-pearl-query.el @@ -0,0 +1,151 @@ +;;; test-pearl-query.el --- Tests for the general issue query -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for `pearl--query-issues-async' and the `--page-issues' pager, +;; with `--graphql-request-async' stubbed. Cover the query/variable +;; construction, pagination across pages, the page-cap truncation, and the +;; full set of result statuses (ok / empty / graphql-failed / request-failed). + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(defun test-lq--page (nodes has-next &optional cursor) + "Build a raw issues-page response with NODES, HAS-NEXT, and CURSOR." + `((data (issues (nodes . ,(vconcat nodes)) + (pageInfo (hasNextPage . ,(if has-next t :json-false)) + (endCursor . ,(or cursor "c"))))))) + +;;; construction + +(ert-deftest test-pearl-query-issues-construction () + "The query targets issues(filter:) and passes the filter + default orderBy." + (let (captured result) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (query variables success-fn _error-fn) + (setq captured (list query variables)) + (funcall success-fn (test-lq--page '(((id . "i1"))) nil))))) + (pearl--query-issues-async '(("assignee" ("isMe" ("eq" . t)))) + (lambda (r) (setq result r))) + (should (string-match-p "issues(filter:" (car captured))) + (should (equal '(("assignee" ("isMe" ("eq" . t)))) (cdr (assoc "filter" (cadr captured))))) + (should (string= "updatedAt" (cdr (assoc "orderBy" (cadr captured))))) + (should (= 100 (cdr (assoc "first" (cadr captured)))))))) + +(ert-deftest test-pearl-query-issues-no-filter-omits-variable () + "With a nil filter, the filter variable is omitted (no filter applied)." + (let (vars) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q variables success-fn _e) + (setq vars variables) + (funcall success-fn (test-lq--page '() nil))))) + (pearl--query-issues-async nil #'ignore) + (should-not (assoc "filter" vars))))) + +(ert-deftest test-pearl-query-issues-order-by-override () + "An explicit ORDER-BY overrides the updatedAt default." + (let (vars) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q variables success-fn _e) + (setq vars variables) + (funcall success-fn (test-lq--page '() nil))))) + (pearl--query-issues-async nil #'ignore 'createdAt) + (should (string= "createdAt" (cdr (assoc "orderBy" vars))))))) + +;;; result statuses + +(ert-deftest test-pearl-query-issues-single-page-ok () + "A single page with issues yields an ok result carrying the raw nodes." + (let (result) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q _v success-fn _e) + (funcall success-fn (test-lq--page '(((id . "i1")) ((id . "i2"))) nil))))) + (pearl--query-issues-async nil (lambda (r) (setq result r))) + (should (eq 'ok (pearl--query-result-status result))) + (should (= 2 (length (pearl--query-result-issues result)))) + (should-not (pearl--query-result-truncated-p result))))) + +(ert-deftest test-pearl-query-issues-empty () + "A page with no nodes yields an empty result, not a failure." + (let (result) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q _v success-fn _e) + (funcall success-fn (test-lq--page '() nil))))) + (pearl--query-issues-async nil (lambda (r) (setq result r))) + (should (eq 'empty (pearl--query-result-status result)))))) + +(ert-deftest test-pearl-query-issues-graphql-error () + "A GraphQL error response surfaces as a graphql-failed result." + (let (result) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q _v success-fn _e) + (funcall success-fn '((errors . (((message . "bad filter")))))))) ) + (pearl--query-issues-async nil (lambda (r) (setq result r))) + (should (eq 'graphql-failed (pearl--query-result-status result))) + (should (string= "bad filter" (pearl--query-result-message result)))))) + +(ert-deftest test-pearl-query-issues-transport-error () + "A transport failure (error callback) surfaces as request-failed." + (let (result) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q _v _success-fn error-fn) + (funcall error-fn "boom" nil nil)))) + (pearl--query-issues-async nil (lambda (r) (setq result r))) + (should (eq 'request-failed (pearl--query-result-status result)))))) + +;;; pagination + +(ert-deftest test-pearl-query-issues-paginates () + "Multiple pages accumulate; the cursor drives the next fetch." + (let ((result nil) (calls 0)) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q variables success-fn _e) + (setq calls (1+ calls)) + (if (assoc "after" variables) + (funcall success-fn (test-lq--page '(((id . "i2"))) nil)) + (funcall success-fn (test-lq--page '(((id . "i1"))) t "cur")))))) + (pearl--query-issues-async nil (lambda (r) (setq result r))) + (should (= 2 calls)) + (should (eq 'ok (pearl--query-result-status result))) + (should (= 2 (length (pearl--query-result-issues result))))))) + +(ert-deftest test-pearl-query-issues-cap-truncates () + "Hitting the page cap stops paging and marks the result truncated." + (let ((result nil) (calls 0) + (pearl-max-issue-pages 3)) + (cl-letf (((symbol-function 'pearl--graphql-request-async) + (lambda (_q _v success-fn _e) + (setq calls (1+ calls)) + (funcall success-fn (test-lq--page '(((id . "x"))) t "cur"))))) + (pearl--query-issues-async nil (lambda (r) (setq result r))) + (should (pearl--query-result-truncated-p result)) + (should (= 3 calls)) + (should (= 3 (length (pearl--query-result-issues result))))))) + +;;; the bulk query fetches comments so the list can render them + +(ert-deftest test-pearl-issues-query-requests-comments () + "The bulk issues query selects comments, so a populated list shows them." + (should (string-match-p "comments[[:space:]]*{[[:space:]]*nodes" pearl--issues-query))) + +(provide 'test-pearl-query) +;;; test-pearl-query.el ends here diff --git a/tests/test-pearl-refresh.el b/tests/test-pearl-refresh.el new file mode 100644 index 0000000..6b8ba7b --- /dev/null +++ b/tests/test-pearl-refresh.el @@ -0,0 +1,148 @@ +;;; test-pearl-refresh.el --- Tests for single-issue refresh -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for `pearl-refresh-current-issue' and its helpers: the single +;; issue fetch (stubbed at the HTTP boundary), the in-place subtree replace, +;; and the per-subtree conflict guard that refuses to clobber unpushed local +;; description edits. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT, default mapping bound." + (declare (indent 1)) + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE"))) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +(defconst test-pearl--refresh-raw + '((id . "a") (identifier . "ENG-1") (title . "Refreshed Title") + (description . "New remote desc.") (priority . 2) + (url . "https://linear.app/x/ENG-1") (updatedAt . "2026-05-23T03:00:00.000Z") + (state (id . "s1") (name . "In Progress") (type . "started")) + (assignee (id . "u1") (name . "Craig") (displayName . "craig") (email . "c@x")) + (team (id . "t1") (key . "ENG") (name . "Engineering")) + (project (id . "p1") (name . "Proj")) + (labels (nodes . [((id . "l1") (name . "bug"))])) + (cycle (id . "c1") (number . 3) (name . "Cycle 3"))) + "A raw issue node as Linear would return it for a single-issue fetch.") + +(defun test-pearl--clean-entry () + "An issue entry whose empty body matches its stored hash (no local edit)." + (format "*** TODO [#B] Stale Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-IDENTIFIER: ENG-1\n:LINEAR-DESC-SHA256: %s\n:END:\n" + (secure-hash 'sha256 ""))) + +;;; --fetch-issue-async + +(ert-deftest test-pearl-fetch-issue-returns-raw-node () + "The single-issue fetch hands its callback the raw issue node." + (testutil-linear-with-response + `((data (issue . ,test-pearl--refresh-raw))) + (let (result) + (pearl--fetch-issue-async "a" (lambda (r) (setq result r))) + (should (string= "Refreshed Title" (cdr (assoc 'title result))))))) + +(ert-deftest test-pearl-fetch-issue-missing-yields-missing () + "A successful response with a null issue node yields `:missing'." + (testutil-linear-with-response + '((data (issue . nil))) + (let ((result 'untouched)) + (pearl--fetch-issue-async "a" (lambda (r) (setq result r))) + (should (eq :missing result))))) + +(ert-deftest test-pearl-fetch-issue-graphql-error-yields-error () + "A GraphQL error response yields `:error', distinct from a missing issue." + (testutil-linear-with-response + '((errors . [((message . "boom"))]) (data . nil)) + (let ((result 'untouched)) + (pearl--fetch-issue-async "a" (lambda (r) (setq result r))) + (should (eq :error result))))) + +;;; refresh-current-issue + +(ert-deftest test-pearl-refresh-replaces-subtree-from-remote () + "A clean refresh rewrites the subtree from the fetched issue." + (test-pearl--in-org (test-pearl--clean-entry) + (cl-letf (((symbol-function 'pearl--fetch-issue-async) + (lambda (_id cb) (funcall cb test-pearl--refresh-raw)))) + (re-search-forward "Stale Title") + (pearl-refresh-current-issue) + (goto-char (point-min)) + (re-search-forward "^\\*\\* ") + ;; heading + drawer reflect the remote + (should (string-match-p "Refreshed Title" (thing-at-point 'line t))) + (should (string= "In Progress" (org-entry-get nil "LINEAR-STATE-NAME"))) + ;; body is the remote description, and provenance matches it + (should (string= "New remote desc." (pearl--issue-body-at-point))) + (should (string= (secure-hash 'sha256 "New remote desc.") + (org-entry-get nil "LINEAR-DESC-SHA256")))))) + +(ert-deftest test-pearl-refresh-stashes-then-replaces-when-body-edited () + "An unpushed local edit is stashed before the refresh overwrites it (decision 4)." + (let ((kill-ring nil)) + (test-pearl--in-org + (format "*** TODO [#B] Stale Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: %s\n:END:\nLocal edit not yet pushed.\n" + (secure-hash 'sha256 "")) + (cl-letf (((symbol-function 'pearl--fetch-issue-async) + (lambda (_id cb) (funcall cb test-pearl--refresh-raw)))) + (pearl-refresh-current-issue) + ;; the unpushed edit was stashed before the overwrite, not lost + (should (string-match-p "Local edit not yet pushed\\." (current-kill 0))) + ;; and the refresh proceeded, replacing the subtree with the remote + (goto-char (point-min)) + (should (re-search-forward "Refreshed Title" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "Local edit not yet pushed\\." nil t)))))) + +(ert-deftest test-pearl-refresh-handles-fetch-error () + "A fetch error leaves the subtree untouched." + (test-pearl--in-org (test-pearl--clean-entry) + (cl-letf (((symbol-function 'pearl--fetch-issue-async) + (lambda (_id cb) (funcall cb :error)))) + (pearl-refresh-current-issue) + (goto-char (point-min)) + (should (re-search-forward "Stale Title" nil t))))) + +(ert-deftest test-pearl-refresh-handles-missing-issue () + "A missing issue leaves the subtree untouched." + (test-pearl--in-org (test-pearl--clean-entry) + (cl-letf (((symbol-function 'pearl--fetch-issue-async) + (lambda (_id cb) (funcall cb :missing)))) + (pearl-refresh-current-issue) + (goto-char (point-min)) + (should (re-search-forward "Stale Title" nil t))))) + +(ert-deftest test-pearl-refresh-not-on-issue-errors () + "Refreshing outside a Linear issue heading signals a user error." + (test-pearl--in-org "* Plain heading\nno id\n" + (should-error (pearl-refresh-current-issue) :type 'user-error))) + +(provide 'test-pearl-refresh) +;;; test-pearl-refresh.el ends here diff --git a/tests/test-pearl-resolve.el b/tests/test-pearl-resolve.el new file mode 100644 index 0000000..d8dda7d --- /dev/null +++ b/tests/test-pearl-resolve.el @@ -0,0 +1,141 @@ +;;; test-pearl-resolve.el --- Tests for name->id resolution helpers -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the per-team cached collection fetch (`--team-collection') and +;; the name->id resolver (`--resolve-team-id'), which back the field commands, +;; the ad-hoc filter, and saved queries. The HTTP boundary is stubbed; the +;; cache is reset around each test. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(defmacro test-pearl--with-clean-caches (&rest body) + "Run BODY with the Linear caches reset and an API key set." + (declare (indent 0)) + `(let ((pearl-api-key "test-key") + (pearl--cache-team-collections nil) + (pearl--cache-states nil) + (pearl--cache-teams nil) + (pearl--cache-issues nil)) + ,@body)) + +(defmacro test-pearl--counting-request (data counter &rest body) + "Run BODY with `request' stubbed to succeed with DATA, counting calls in COUNTER." + (declare (indent 2)) + `(cl-letf (((symbol-function 'request) + (lambda (_url &rest args) + (cl-incf ,counter) + (let ((cb (plist-get args :success))) + (when cb (funcall cb :data ,data)))))) + ,@body)) + +;;; --team-collection + +(ert-deftest test-pearl-team-collection-fetches-and-caches () + "A collection is fetched once and served from cache on the second call." + (test-pearl--with-clean-caches + (let ((calls 0)) + (test-pearl--counting-request + '((data (team (projects (nodes . [((id . "p1") (name . "Foo")) + ((id . "p2") (name . "Bar"))]))))) calls + (let ((first (pearl--team-collection 'projects "team-1"))) + (should (= 2 (length first))) + (should (string= "p1" (cdr (assoc 'id (car first))))) + (pearl--team-collection 'projects "team-1") + (should (= 1 calls))))))) + +(ert-deftest test-pearl-team-collection-force-refetches () + "A force refresh bypasses the cache and fetches again." + (test-pearl--with-clean-caches + (let ((calls 0)) + (test-pearl--counting-request + '((data (team (labels (nodes . [((id . "l1") (name . "bug"))]))))) calls + (pearl--team-collection 'labels "team-1") + (pearl--team-collection 'labels "team-1" t) + (should (= 2 calls)))))) + +(ert-deftest test-pearl-team-collection-keyed-by-team () + "Different teams cache separately." + (test-pearl--with-clean-caches + (let ((calls 0)) + (test-pearl--counting-request + '((data (team (members (nodes . [((id . "u1") (name . "Craig"))]))))) calls + (pearl--team-collection 'members "team-1") + (pearl--team-collection 'members "team-2") + (should (= 2 calls)))))) + +;;; --resolve-team-id + +(ert-deftest test-pearl-resolve-unique-name () + "A name with one match resolves to that id." + (test-pearl--with-clean-caches + (cl-letf (((symbol-function 'pearl--team-collection) + (lambda (&rest _) '(((id . "p1") (name . "Foo")) + ((id . "p2") (name . "Bar")))))) + (should (string= "p1" (pearl--resolve-team-id 'projects "Foo" "team-1"))) + ;; case-insensitive + (should (string= "p2" (pearl--resolve-team-id 'projects "bar" "team-1")))))) + +(ert-deftest test-pearl-resolve-no-match-is-nil () + "A name with no match resolves to nil." + (test-pearl--with-clean-caches + (cl-letf (((symbol-function 'pearl--team-collection) + (lambda (&rest _) '(((id . "p1") (name . "Foo")))))) + (should-not (pearl--resolve-team-id 'projects "Missing" "team-1"))))) + +(ert-deftest test-pearl-resolve-member-by-display-name-or-email () + "Members match on name, displayName, or email." + (test-pearl--with-clean-caches + (cl-letf (((symbol-function 'pearl--team-collection) + (lambda (&rest _) + '(((id . "u1") (name . "Craig Jennings") (displayName . "cj") + (email . "c@x.com")))))) + (should (string= "u1" (pearl--resolve-team-id 'members "cj" "team-1"))) + (should (string= "u1" (pearl--resolve-team-id 'members "c@x.com" "team-1")))))) + +(ert-deftest test-pearl-resolve-ambiguous-prompts () + "When several nodes share a name, the resolver prompts and returns the choice." + (test-pearl--with-clean-caches + (cl-letf (((symbol-function 'pearl--team-collection) + (lambda (&rest _) '(((id . "u1") (name . "Alex") (displayName . "alex-a")) + ((id . "u2") (name . "Alex") (displayName . "alex-b"))))) + ((symbol-function 'completing-read) + (lambda (_prompt collection &rest _) + ;; pick the entry whose id is u2 + (car (rassoc "u2" collection))))) + (should (string= "u2" (pearl--resolve-team-id 'members "Alex" "team-1")))))) + +;;; clear-cache + +(ert-deftest test-pearl-clear-cache-resets () + "Clearing the cache empties the collection and per-team caches." + (let ((pearl--cache-team-collections '(((projects . "t") . x))) + (pearl--cache-states '(("t" . y))) + (pearl--cache-teams '(z))) + (pearl-clear-cache) + (should-not pearl--cache-team-collections) + (should-not pearl--cache-states) + (should-not pearl--cache-teams))) + +(provide 'test-pearl-resolve) +;;; test-pearl-resolve.el ends here diff --git a/tests/test-pearl-result.el b/tests/test-pearl-result.el new file mode 100644 index 0000000..606c3b0 --- /dev/null +++ b/tests/test-pearl-result.el @@ -0,0 +1,98 @@ +;;; test-pearl-result.el --- Tests for the query result shape -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the tagged query-result shape and `--classify-response': the five +;; statuses (ok / empty / invalid-filter / request-failed / graphql-failed), +;; the ok/error predicates, the GraphQL error-message extraction (vector and +;; list forms), and the truncated flag. All pure -- no network. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +;;; classify-response + +(ert-deftest test-pearl-result-classify-nil-is-request-failed () + "A nil response is a transport failure." + (let ((r (pearl--classify-response nil))) + (should (eq 'request-failed (pearl--query-result-status r))) + (should (pearl--query-result-error-p r)) + (should (stringp (pearl--query-result-message r))))) + +(ert-deftest test-pearl-result-classify-errors-is-graphql-failed () + "A response carrying errors is a GraphQL failure with the message extracted." + (let ((r (pearl--classify-response '((errors . (((message . "bad filter")))))))) + (should (eq 'graphql-failed (pearl--query-result-status r))) + (should (string= "bad filter" (pearl--query-result-message r))))) + +(ert-deftest test-pearl-result-classify-errors-vector-form () + "Errors as a vector (the live API shape) still yield the first message." + (let ((r (pearl--classify-response '((errors . [((message . "nope"))]))))) + (should (eq 'graphql-failed (pearl--query-result-status r))) + (should (string= "nope" (pearl--query-result-message r))))) + +(ert-deftest test-pearl-result-classify-data-with-issues-is-ok () + "A data response with issues is ok and carries the issues." + (let ((r (pearl--classify-response '((data (issues))) '(i1 i2)))) + (should (eq 'ok (pearl--query-result-status r))) + (should (pearl--query-result-ok-p r)) + (should (equal '(i1 i2) (pearl--query-result-issues r))))) + +(ert-deftest test-pearl-result-classify-data-without-issues-is-empty () + "A data response with no issues is empty, not a failure." + (let ((r (pearl--classify-response '((data (issues))) '()))) + (should (eq 'empty (pearl--query-result-status r))) + (should (pearl--query-result-ok-p r)) + (should-not (pearl--query-result-error-p r)))) + +(ert-deftest test-pearl-result-classify-no-data-no-errors-is-request-failed () + "A response with neither data nor errors is treated as malformed/transport." + (let ((r (pearl--classify-response '((extensions . nil))))) + (should (eq 'request-failed (pearl--query-result-status r))))) + +(ert-deftest test-pearl-result-classify-carries-truncated-flag () + "The truncated flag is carried through on a successful result." + (let ((r (pearl--classify-response '((data (issues))) '(i1) t))) + (should (pearl--query-result-truncated-p r)))) + +(ert-deftest test-pearl-result-classify-ok-not-truncated-by-default () + "Without the truncated argument the flag is nil." + (let ((r (pearl--classify-response '((data (issues))) '(i1)))) + (should-not (pearl--query-result-truncated-p r)))) + +;;; invalid-filter + +(ert-deftest test-pearl-result-invalid-filter () + "An invalid-filter result is an error carrying its message." + (let ((r (pearl--invalid-filter-result "bad :priority"))) + (should (eq 'invalid-filter (pearl--query-result-status r))) + (should (pearl--query-result-error-p r)) + (should-not (pearl--query-result-ok-p r)) + (should (string= "bad :priority" (pearl--query-result-message r))))) + +;;; error-message extraction + +(ert-deftest test-pearl-result-graphql-error-message-nil-when-absent () + "With no errors key, the error-message extractor returns nil." + (should (null (pearl--graphql-error-message '((data (issues))))))) + +(provide 'test-pearl-result) +;;; test-pearl-result.el ends here diff --git a/tests/test-pearl-saved.el b/tests/test-pearl-saved.el new file mode 100644 index 0000000..63a3f8c --- /dev/null +++ b/tests/test-pearl-saved.el @@ -0,0 +1,112 @@ +;;; test-pearl-saved.el --- Tests for saved queries + sort -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for local saved queries and the sort layer: the client-side +;; `--sort-issues', the sort->orderBy mapping, and `pearl-run-saved-query' +;; threading the filter, source, and order through. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +;;; --sort-issues + +(defconst test-pearl--sort-sample + '((:title "banana" :priority 2 :updated-at "2026-05-23T10:00:00.000Z") + (:title "apple" :priority 1 :updated-at "2026-05-23T12:00:00.000Z") + (:title "cherry" :priority 3 :updated-at "2026-05-23T08:00:00.000Z")) + "Three issues for exercising the client-side sort.") + +(ert-deftest test-pearl-sort-issues-nil-sort-unchanged () + "With no sort key, the issues are returned in their original order." + (should (equal test-pearl--sort-sample + (pearl--sort-issues test-pearl--sort-sample nil nil)))) + +(ert-deftest test-pearl-sort-issues-title-asc () + "Sorting by title ascending orders alphabetically." + (let ((out (pearl--sort-issues test-pearl--sort-sample 'title 'asc))) + (should (equal '("apple" "banana" "cherry") + (mapcar (lambda (i) (plist-get i :title)) out))))) + +(ert-deftest test-pearl-sort-issues-updated-desc-default () + "Sorting by updated, descending, puts the most recent first." + (let ((out (pearl--sort-issues test-pearl--sort-sample 'updated 'desc))) + (should (string= "apple" (plist-get (car out) :title))) + (should (string= "cherry" (plist-get (car (last out)) :title))))) + +(ert-deftest test-pearl-sort-issues-priority-asc () + "Sorting by priority ascending orders by the numeric value." + (let ((out (pearl--sort-issues test-pearl--sort-sample 'priority 'asc))) + (should (equal '(1 2 3) (mapcar (lambda (i) (plist-get i :priority)) out))))) + +;;; --sort->order-by + +(ert-deftest test-pearl-sort-to-order-by () + "Updated/created map to the server orderBy; everything else defaults to updatedAt." + (should (eq 'updatedAt (pearl--sort->order-by 'updated))) + (should (eq 'createdAt (pearl--sort->order-by 'created))) + (should (eq 'updatedAt (pearl--sort->order-by 'title)))) + +;;; run-saved-query + +(ert-deftest test-pearl-run-saved-query-threads-filter-and-source () + "Running a saved query compiles its filter and renders with a sorted source." + (let ((pearl-saved-queries + '(("My bugs" :filter (:labels ("bug") :open t) :sort priority :order asc))) + (built nil) (rendered-source nil) (order nil)) + (cl-letf (((symbol-function 'pearl--build-issue-filter) + (lambda (plist) (setq built plist) '((compiled . t)))) + ((symbol-function 'pearl--query-issues-async) + (lambda (_filter cb &optional ord) (setq order ord) + (funcall cb (pearl--make-query-result 'ok :issues nil)))) + ((symbol-function 'pearl--render-query-result) + (lambda (_result source) (setq rendered-source source)))) + (pearl-run-saved-query "My bugs") + (should (equal '(:labels ("bug") :open t) built)) + (should (eq 'priority (plist-get rendered-source :sort))) + (should (eq 'asc (plist-get rendered-source :order))) + (should (eq 'filter (plist-get rendered-source :type))) + (should (eq 'updatedAt order))))) + +(ert-deftest test-pearl-run-saved-query-unknown-errors () + "An unknown saved-query name signals a user error." + (let ((pearl-saved-queries '(("Known" :filter (:open t))))) + (should-error (pearl-run-saved-query "Missing") :type 'user-error))) + +;;; render applies the source sort + +(ert-deftest test-pearl-render-query-result-sorts-by-source () + "The render boundary sorts issues by the source's sort/order before writing." + (let ((written nil) + (source '(:type filter :name "By title" :filter nil :sort title :order asc))) + (cl-letf (((symbol-function 'pearl--normalize-issue) #'identity) + ((symbol-function 'pearl--update-org-from-issues) + (lambda (issues &optional _s _t) (setq written issues)))) + (pearl--render-query-result + (pearl--make-query-result + 'ok :issues '((:title "banana") (:title "apple"))) + source) + (should (equal '("apple" "banana") + (mapcar (lambda (i) (plist-get i :title)) written)))))) + +(provide 'test-pearl-saved) +;;; test-pearl-saved.el ends here diff --git a/tests/test-pearl-smoke.el b/tests/test-pearl-smoke.el new file mode 100644 index 0000000..53c4d06 --- /dev/null +++ b/tests/test-pearl-smoke.el @@ -0,0 +1,37 @@ +;;; test-pearl-smoke.el --- Harness smoke test for pearl -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Plumbing-proof smoke test: confirms the harness loads the package and +;; defines its public commands. Behavior coverage lives in the per-area +;; test files (test-pearl-mapping.el, -format.el, ...). + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) + +(ert-deftest test-pearl-smoke-feature-loaded () + "The package source loads and defines its public commands." + (should (featurep 'pearl)) + (should (fboundp 'pearl-list-issues)) + (should (fboundp 'pearl-new-issue))) + +(provide 'test-pearl-smoke) +;;; test-pearl-smoke.el ends here diff --git a/tests/test-pearl-states.el b/tests/test-pearl-states.el new file mode 100644 index 0000000..713cb78 --- /dev/null +++ b/tests/test-pearl-states.el @@ -0,0 +1,134 @@ +;;; test-pearl-states.el --- Tests for pearl state management -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for workflow-state fetching, state name -> id resolution, and the +;; two state-update entry points. Covers the guard that skips the mutation +;; when the state name doesn't resolve, so no request fires with a null id. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +;;; pearl-get-states-async + +(ert-deftest test-pearl-get-states-async-parses-nodes () + "Workflow states are unwrapped and passed to the callback." + (let ((got nil)) + (testutil-linear-with-response + '((data (team (states (nodes . (((id . "s1") (name . "Todo")) + ((id . "s2") (name . "Done")))))))) + (pearl-get-states-async "team-1" (lambda (states) (setq got states)))) + (should (= 2 (length got))) + (should (string-equal "s1" (cdr (assoc 'id (car got))))))) + +;;; pearl--get-state-id-by-name + +(ert-deftest test-pearl-get-state-id-by-name-found () + "A state whose name matches (case-insensitively) resolves to its id." + (let ((pearl--cache-states nil)) + (testutil-linear-with-response + '((data (team (states (nodes . (((id . "s1") (name . "Todo")) + ((id . "s2") (name . "Done")))))))) + (should (string-equal "s2" (pearl--get-state-id-by-name "done" "team-1")))))) + +(ert-deftest test-pearl-get-state-id-by-name-not-found () + "A state name absent from the team resolves to nil." + (let ((pearl--cache-states nil)) + (testutil-linear-with-response + '((data (team (states (nodes . (((id . "s1") (name . "Todo")))))))) + (should (null (pearl--get-state-id-by-name "Archived" "team-1")))))) + +(ert-deftest test-pearl-state-lookup-caches-per-team () + "A second lookup for the same team is served from cache, no new request." + (let ((pearl-api-key "test-key") + (pearl--cache-states nil) + (calls 0)) + (cl-letf (((symbol-function 'request) + (lambda (_url &rest args) + (setq calls (1+ calls)) + (funcall (plist-get args :success) + :data '((data (team (states (nodes . (((id . "s1") (name . "Todo")) + ((id . "s2") (name . "Done")))))))))))) + (should (string-equal "s2" (pearl--get-state-id-by-name "Done" "team-1"))) + (should (string-equal "s1" (pearl--get-state-id-by-name "Todo" "team-1"))) + (should (= 1 calls))))) + +;;; pearl-update-issue-state (sync) -- nil-state-id guard + +(ert-deftest test-pearl-update-issue-state-nil-state-id-skips-request () + "When the state name doesn't resolve, no mutation request is fired." + (let ((requested nil) + (pearl-api-key "test-key")) + (cl-letf (((symbol-function 'pearl--get-state-id-by-name) (lambda (_s _t) nil)) + ((symbol-function 'request) (lambda (&rest _) (setq requested t)))) + (pearl-update-issue-state "i-1" "Nonexistent" "team-1") + (should-not requested)))) + +(ert-deftest test-pearl-update-issue-state-resolved-fires-request () + "When the state resolves, the mutation request is fired." + (let ((requested nil) + (pearl-api-key "test-key")) + (cl-letf (((symbol-function 'pearl--get-state-id-by-name) (lambda (_s _t) "s2")) + ((symbol-function 'request) + (lambda (_url &rest args) + (setq requested t) + (let ((cb (plist-get args :success))) + (when cb (funcall cb :data '((data (issueUpdate (success . t)))))))))) + (pearl-update-issue-state "i-1" "Done" "team-1") + (should requested)))) + +;;; pearl--update-issue-state-async -- nil-state-id guard + +(ert-deftest test-pearl-update-issue-state-async-nil-state-id-skips-request () + "The async update also short-circuits when the state name doesn't resolve." + (let ((requested nil) + (pearl-api-key "test-key")) + (cl-letf (((symbol-function 'pearl--get-state-id-by-name) (lambda (_s _t) nil)) + ((symbol-function 'request) (lambda (&rest _) (setq requested t)))) + (pearl--update-issue-state-async "i-1" "Nonexistent" "team-1") + (should-not requested)))) + +(ert-deftest test-pearl-update-issue-state-async-success-runs () + "The async success handler runs on a successful update." + (let ((pearl-api-key "test-key")) + (cl-letf (((symbol-function 'pearl--get-state-id-by-name) (lambda (_s _t) "s2")) + ((symbol-function 'request) + (lambda (_url &rest args) + (funcall (plist-get args :success) + :data '((data (issueUpdate (success . t)))))))) + (should (progn (pearl--update-issue-state-async "i-1" "Done" "team-1") t))))) + +(ert-deftest test-pearl-update-issue-state-async-error-runs () + "The async error handler runs on a transport error." + (let ((pearl-api-key "test-key")) + (cl-letf (((symbol-function 'pearl--get-state-id-by-name) (lambda (_s _t) "s2")) + ((symbol-function 'request) + (lambda (_url &rest args) + (funcall (plist-get args :error) + :error-thrown "boom" + :response (make-request-response :status-code 500) + :data nil)))) + (should (progn (pearl--update-issue-state-async "i-1" "Done" "team-1") t))))) + +(provide 'test-pearl-states) +;;; test-pearl-states.el ends here diff --git a/tests/test-pearl-surface.el b/tests/test-pearl-surface.el new file mode 100644 index 0000000..4c2b7e5 --- /dev/null +++ b/tests/test-pearl-surface.el @@ -0,0 +1,81 @@ +;;; test-pearl-surface.el --- Tests for surfacing the active buffer -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for `pearl--surface-buffer': bring the active org buffer to a window +;; after a command updates it, gated on `pearl-surface-buffer', focus-following +;; gated on `pearl-surface-select-window', and skipped when the buffer is dead +;; or already visible. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(ert-deftest test-pearl-surface-buffer-disabled-is-noop () + "With `pearl-surface-buffer' nil, nothing is displayed." + (let ((pearl-surface-buffer nil) (shown nil)) + (cl-letf (((symbol-function 'display-buffer) (lambda (&rest _) (setq shown t))) + ((symbol-function 'pop-to-buffer) (lambda (&rest _) (setq shown t)))) + (with-temp-buffer + (pearl--surface-buffer (current-buffer)) + (should-not shown))))) + +(ert-deftest test-pearl-surface-buffer-shows-when-buried () + "A live, un-displayed buffer is shown via `display-buffer' by default." + (let ((pearl-surface-buffer t) (pearl-surface-select-window nil) (shown nil)) + (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) nil)) + ((symbol-function 'display-buffer) (lambda (b &rest _) (setq shown b))) + ((symbol-function 'pop-to-buffer) (lambda (&rest _) (setq shown 'pop)))) + (with-temp-buffer + (pearl--surface-buffer (current-buffer)) + (should (eq shown (current-buffer))))))) + +(ert-deftest test-pearl-surface-buffer-skips-when-already-shown () + "A buffer already visible in some window is left alone." + (let ((pearl-surface-buffer t) (shown nil)) + (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) 'a-window)) + ((symbol-function 'display-buffer) (lambda (&rest _) (setq shown t))) + ((symbol-function 'pop-to-buffer) (lambda (&rest _) (setq shown t)))) + (with-temp-buffer + (pearl--surface-buffer (current-buffer)) + (should-not shown))))) + +(ert-deftest test-pearl-surface-buffer-select-window-uses-pop-to-buffer () + "With `pearl-surface-select-window' non-nil, focus follows via `pop-to-buffer'." + (let ((pearl-surface-buffer t) (pearl-surface-select-window t) (how nil)) + (cl-letf (((symbol-function 'get-buffer-window) (lambda (&rest _) nil)) + ((symbol-function 'display-buffer) (lambda (&rest _) (setq how 'display))) + ((symbol-function 'pop-to-buffer) (lambda (&rest _) (setq how 'pop)))) + (with-temp-buffer + (pearl--surface-buffer (current-buffer)) + (should (eq how 'pop)))))) + +(ert-deftest test-pearl-surface-buffer-dead-buffer-is-noop () + "A killed buffer is never surfaced." + (let ((pearl-surface-buffer t) (shown nil) (buf (generate-new-buffer "x"))) + (kill-buffer buf) + (cl-letf (((symbol-function 'display-buffer) (lambda (&rest _) (setq shown t))) + ((symbol-function 'pop-to-buffer) (lambda (&rest _) (setq shown t)))) + (pearl--surface-buffer buf) + (should-not shown)))) + +(provide 'test-pearl-surface) +;;; test-pearl-surface.el ends here diff --git a/tests/test-pearl-sync-hooks.el b/tests/test-pearl-sync-hooks.el new file mode 100644 index 0000000..05864e7 --- /dev/null +++ b/tests/test-pearl-sync-hooks.el @@ -0,0 +1,175 @@ +;;; test-pearl-sync-hooks.el --- Tests for pearl org sync hooks -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the org sync hook wiring: enable/disable add and remove +;; buffer-local hooks; the after-save hook only fires for linear.org buffers; +;; and per-heading sync degrades gracefully when point is before any heading. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +;;; enable / disable + +(ert-deftest test-pearl-enable-org-sync-adds-buffer-local-hooks () + "Enabling sync adds both hook functions buffer-locally." + (with-temp-buffer + (pearl-enable-org-sync) + (should (memq 'pearl-org-hook-function after-save-hook)) + (should (memq 'pearl-sync-org-to-linear org-after-todo-state-change-hook)))) + +(ert-deftest test-pearl-disable-org-sync-removes-hooks () + "Disabling sync removes both hook functions." + (with-temp-buffer + (pearl-enable-org-sync) + (pearl-disable-org-sync) + (should-not (memq 'pearl-org-hook-function after-save-hook)) + (should-not (memq 'pearl-sync-org-to-linear org-after-todo-state-change-hook)))) + +;;; org-hook-function buffer guard + +(ert-deftest test-pearl-org-hook-function-skips-other-buffer () + "The after-save hook does nothing in a buffer that isn't the configured file." + (let ((called nil) + (pearl-org-file-path "/tmp/linear.org")) + (cl-letf (((symbol-function 'pearl-sync-org-to-linear) (lambda () (setq called t)))) + (with-temp-buffer + (setq buffer-file-name "/tmp/scratch.org") + (pearl-org-hook-function) + (should-not called))))) + +(ert-deftest test-pearl-org-hook-function-syncs-configured-buffer () + "The after-save hook syncs when the buffer visits `pearl-org-file-path'." + (let ((called nil) + (pearl-org-file-path "/tmp/linear.org")) + (cl-letf (((symbol-function 'pearl-sync-org-to-linear) (lambda () (setq called t)))) + (with-temp-buffer + (setq buffer-file-name "/tmp/linear.org") + (pearl-org-hook-function) + (should called))))) + +(ert-deftest test-pearl-org-hook-function-honors-custom-path () + "A non-default `pearl-org-file-path' is what the hook matches on. +Regression: the hook used to hardcode a \"linear.org$\" regex, so a buffer +named linear.org fired even when the configured file was elsewhere, and a +custom-named configured file never fired." + (let ((called nil) + (pearl-org-file-path "/tmp/my-linear-issues.org")) + (cl-letf (((symbol-function 'pearl-sync-org-to-linear) (lambda () (setq called t)))) + ;; A buffer literally named linear.org must NOT fire when the configured + ;; file is something else. + (with-temp-buffer + (setq buffer-file-name "/tmp/linear.org") + (pearl-org-hook-function) + (should-not called)) + ;; The configured custom-named file DOES fire. + (with-temp-buffer + (setq buffer-file-name "/tmp/my-linear-issues.org") + (pearl-org-hook-function) + (should called))))) + +(ert-deftest test-pearl-org-hook-function-matches-through-symlink () + "A configured path and a visited symlink to the same file match via truename. +The hook resolves both sides with `file-truename', so a symlink to the +configured file still syncs -- this guards the choice of truename over a raw +string compare." + (let ((real (make-temp-file "linear-real-" nil ".org")) + (link (make-temp-file "linear-link-" nil ".org")) + (called nil)) + (unwind-protect + (progn + (delete-file link) + (make-symbolic-link real link) + (let ((pearl-org-file-path real)) + (cl-letf (((symbol-function 'pearl-sync-org-to-linear) + (lambda () (setq called t)))) + (with-temp-buffer + (setq buffer-file-name link) + (pearl-org-hook-function) + (should called))))) + (when (file-exists-p link) (delete-file link)) + (when (file-exists-p real) (delete-file real))))) + +(ert-deftest test-pearl-org-hook-function-nil-path-no-op () + "With `pearl-org-file-path' nil, the hook is a no-op and does not error." + (let ((called nil) + (pearl-org-file-path nil)) + (cl-letf (((symbol-function 'pearl-sync-org-to-linear) (lambda () (setq called t)))) + (with-temp-buffer + (setq buffer-file-name "/tmp/linear.org") + (should (progn (pearl-org-hook-function) t)) + (should-not called))))) + +;;; sync-current-heading-to-linear + +(ert-deftest test-pearl-sync-current-heading-before-first-heading-no-error () + "Syncing with point before the first heading degrades gracefully. + +Regression: `org-back-to-heading' signals \"before first heading\" in the +preamble, which must not propagate out of the sync entry point." + (cl-letf (((symbol-function 'pearl--process-heading-at-point) (lambda () nil))) + (with-temp-buffer + (insert "#+TITLE: x\n\npreamble line\n") + (org-mode) + (goto-char (point-min)) + (should (progn (pearl-sync-current-heading-to-linear) t))))) + +(ert-deftest test-pearl-sync-current-heading-processes-on-heading () + "Syncing from within an entry processes that heading." + (let ((called nil)) + (cl-letf (((symbol-function 'pearl--process-heading-at-point) + (lambda () (setq called t)))) + (with-temp-buffer + (insert "* Top\n*** TODO x\n") + (org-mode) + (goto-char (point-max)) + (pearl-sync-current-heading-to-linear) + (should called))))) + +;;; sync-org-to-linear dispatcher + +(ert-deftest test-pearl-sync-org-to-linear-org-todo-syncs-current-heading () + "When invoked from `org-todo', only the current heading is synced." + (let ((called nil) + (this-command 'org-todo)) + (cl-letf (((symbol-function 'pearl-sync-current-heading-to-linear) + (lambda () (setq called t)))) + (pearl-sync-org-to-linear) + (should called)))) + +(ert-deftest test-pearl-sync-org-to-linear-otherwise-scans-whole-file () + "Outside `org-todo', every matching heading in the buffer is processed." + (let ((count 0) + (this-command 'some-other-command) + (pearl-state-to-todo-mapping '(("Todo" . "TODO") ("Done" . "DONE"))) + (pearl-todo-states-pattern nil) + (pearl--todo-states-pattern-source nil)) + (cl-letf (((symbol-function 'pearl--process-heading-at-point) + (lambda () (setq count (1+ count))))) + (with-temp-buffer + (insert "*** TODO a\n*** DONE b\n") + (org-mode) + (pearl-sync-org-to-linear) + (should (= 2 count)))))) + +(provide 'test-pearl-sync-hooks) +;;; test-pearl-sync-hooks.el ends here diff --git a/tests/test-pearl-sync-wrappers.el b/tests/test-pearl-sync-wrappers.el new file mode 100644 index 0000000..a5c9c70 --- /dev/null +++ b/tests/test-pearl-sync-wrappers.el @@ -0,0 +1,83 @@ +;;; test-pearl-sync-wrappers.el --- Tests for sync wrappers + pagination -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the synchronous busy-wait wrappers (teams, states, create) and +;; the completing-read-driven selectors. The HTTP boundary is stubbed; +;; `completing-read' is stubbed for the selectors. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +;;; Synchronous wrappers + +(ert-deftest test-pearl-get-teams-sync-returns-teams () + "The sync teams wrapper returns the async result." + (testutil-linear-with-response + '((data (teams (nodes . (((id . "t1") (name . "Eng"))))))) + (should (= 1 (length (pearl-get-teams)))))) + +(ert-deftest test-pearl-get-states-sync-returns-states () + "The sync states wrapper returns the async result." + (testutil-linear-with-response + '((data (team (states (nodes . (((id . "s1") (name . "Todo")))))) )) + (should (= 1 (length (pearl-get-states "team-1")))))) + +(ert-deftest test-pearl-create-issue-sync-returns-issue () + "The sync create wrapper returns the created issue node." + (testutil-linear-with-response + '((data (issueCreate (success . t) (issue (id . "i1") (identifier . "ENG-1") (title . "T"))))) + (should (string-equal "ENG-1" (cdr (assoc 'identifier (pearl-create-issue "T" "" "team"))))))) + +(ert-deftest test-pearl-sync-wrapper-times-out-without-callback () + "A sync wrapper returns nil instead of hanging when no callback fires." + (let ((pearl-request-timeout 0.3) + (pearl-api-key "test-key")) + (cl-letf (((symbol-function 'request) (lambda (&rest _) nil))) + (should (null (pearl-get-teams)))))) + +;;; Selectors (completing-read stubbed) + +(ert-deftest test-pearl-select-team-returns-chosen-team () + "Selecting a team returns the matching team alist." + (let ((pearl--cache-teams '(((id . "t1") (name . "Eng")) + ((id . "t2") (name . "Ops"))))) + (cl-letf (((symbol-function 'completing-read) (lambda (&rest _) "Ops"))) + (should (string-equal "t2" (cdr (assoc 'id (pearl-select-team)))))))) + +(ert-deftest test-pearl-select-project-returns-chosen-project () + "Selecting a project returns the matching project alist." + (cl-letf (((symbol-function 'pearl-get-projects) + (lambda (_tid) '(((id . "p1") (name . "Platform"))))) + ((symbol-function 'completing-read) (lambda (&rest _) "Platform"))) + (should (string-equal "p1" (cdr (assoc 'id (pearl-select-project "team-1"))))))) + +(ert-deftest test-pearl-select-project-none-returns-nil () + "Choosing None returns nil." + (cl-letf (((symbol-function 'pearl-get-projects) + (lambda (_tid) '(((id . "p1") (name . "Platform"))))) + ((symbol-function 'completing-read) (lambda (&rest _) "None"))) + (should (null (pearl-select-project "team-1"))))) + +(provide 'test-pearl-sync-wrappers) +;;; test-pearl-sync-wrappers.el ends here diff --git a/tests/test-pearl-sync.el b/tests/test-pearl-sync.el new file mode 100644 index 0000000..6127914 --- /dev/null +++ b/tests/test-pearl-sync.el @@ -0,0 +1,206 @@ +;;; test-pearl-sync.el --- Tests for description sync-back -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for the explicit description sync-back: the pure conflict gate +;; (`pearl--sync-decision'), the org body extractor +;; (`pearl--issue-body-at-point'), the two network helpers (fetch the +;; remote description, push an updated description -- both stubbed at the HTTP +;; boundary), and the orchestrating command `pearl-sync-current-issue' +;; across its no-op / clean-push / conflict branches. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT at point-min." + (declare (indent 1)) + `(let ((org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +;;; --sync-decision (pure conflict gate) + +(ert-deftest test-pearl-sync-decision-noop-no-local-edit () + "Local matches the stored baseline: no local edit, no push." + (let ((md "the description")) + (should (eq :noop (pearl--sync-decision + md (secure-hash 'sha256 md) "remote moved on"))))) + +(ert-deftest test-pearl-sync-decision-push-remote-unchanged () + "Local edited and remote still equals the baseline: clean push." + (should (eq :push (pearl--sync-decision + "edited locally" (secure-hash 'sha256 "baseline") "baseline")))) + +(ert-deftest test-pearl-sync-decision-conflict-both-changed () + "Local and remote both moved away from the baseline, differently: conflict." + (should (eq :conflict (pearl--sync-decision + "edited local" (secure-hash 'sha256 "baseline") "edited remote")))) + +(ert-deftest test-pearl-sync-decision-noop-converged () + "Local and remote ended up identical though both differ from baseline: no push." + (should (eq :noop (pearl--sync-decision + "same new text" (secure-hash 'sha256 "baseline") "same new text")))) + +;;; --issue-body-at-point (org body extractor) + +(ert-deftest test-pearl-issue-body-after-drawer () + "The body is the text after the drawer, trimmed." + (test-pearl--in-org + "*** TODO ENG-1 Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nThe body line.\nSecond line.\n" + (re-search-forward "Title") + (should (string= "The body line.\nSecond line." + (pearl--issue-body-at-point))))) + +(ert-deftest test-pearl-issue-body-empty () + "An entry with no body yields the empty string." + (test-pearl--in-org + "*** TODO ENG-1 Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (should (string= "" (pearl--issue-body-at-point))))) + +(ert-deftest test-pearl-issue-body-stops-before-comments () + "The description body stops before a child Comments subtree." + (test-pearl--in-org + "*** TODO ENG-1 Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nDesc body.\n**** Comments\n***** bob -- ts\nhi\n" + (should (string= "Desc body." (pearl--issue-body-at-point))))) + +(ert-deftest test-pearl-issue-body-from-inside-body () + "Extraction works with point already inside the body." + (test-pearl--in-org + "*** TODO ENG-1 Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nDesc body.\nmore.\n" + (goto-char (point-max)) + (should (string= "Desc body.\nmore." (pearl--issue-body-at-point))))) + +;;; network helpers (stubbed at the HTTP boundary) + +(ert-deftest test-pearl-fetch-issue-description-parses-payload () + "The fetch helper returns the remote description and timestamp as a plist." + (testutil-linear-with-response + '((data (issue (description . "remote markdown") + (updatedAt . "2026-05-23T00:00:00.000Z")))) + (let (result) + (pearl--fetch-issue-description-async + "id-1" (lambda (r) (setq result r))) + (should (string= "remote markdown" (plist-get result :description))) + (should (string= "2026-05-23T00:00:00.000Z" (plist-get result :updated-at)))))) + +(ert-deftest test-pearl-update-issue-description-success () + "A successful issueUpdate reports success and carries the new timestamp." + (testutil-linear-with-response + '((data (issueUpdate (success . t) + (issue (id . "id-1") + (updatedAt . "2026-05-23T01:00:00.000Z"))))) + (let (result) + (pearl--update-issue-description-async + "id-1" "new body" (lambda (r) (setq result r))) + (should (eq t (plist-get result :success))) + (should (string= "2026-05-23T01:00:00.000Z" (plist-get result :updated-at)))))) + +(ert-deftest test-pearl-update-issue-description-soft-fail () + "A non-success issueUpdate reports failure rather than erroring." + (testutil-linear-with-response + '((data (issueUpdate (success . :json-false) (issue . nil)))) + (let ((called nil) result) + (pearl--update-issue-description-async + "id-1" "new body" (lambda (r) (setq called t result r))) + (should called) + (should-not (plist-get result :success))))) + +;;; pearl-sync-current-issue (orchestration branches) + +(defmacro test-pearl--with-sync-stubs (fetch-remote update-spy &rest body) + "Run BODY with the two network helpers stubbed. +FETCH-REMOTE is the plist the fetch helper hands its callback. UPDATE-SPY is +a symbol bound to a list that captures the markdown passed to the update +helper (nil when never called); the update helper reports success." + (declare (indent 2)) + `(cl-letf (((symbol-function 'pearl--fetch-issue-description-async) + (lambda (_id cb) (funcall cb ,fetch-remote))) + ((symbol-function 'pearl--update-issue-description-async) + (lambda (_id md cb) + (push md ,update-spy) + (funcall cb '(:success t :updated-at "2026-05-23T02:00:00.000Z"))))) + ,@body)) + +(ert-deftest test-pearl-sync-current-issue-noop-skips-network () + "No local edit: neither the fetch nor the update helper is called." + (let ((md "Hello **world** and `code`.") + (fetched nil) (updates nil)) + (test-pearl--in-org + (format "*** TODO ENG-1 Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: %s\n:END:\n%s\n" + (secure-hash 'sha256 "Hello **world** and `code`.") + (pearl--md-to-org "Hello **world** and `code`.")) + (ignore md) + (cl-letf (((symbol-function 'pearl--fetch-issue-description-async) + (lambda (&rest _) (setq fetched t))) + ((symbol-function 'pearl--update-issue-description-async) + (lambda (&rest _) (push 'called updates)))) + (pearl-sync-current-issue) + (should-not fetched) + (should-not updates))))) + +(ert-deftest test-pearl-sync-current-issue-push-updates-provenance () + "Local edit + remote unchanged: push the rendered markdown, update the hash." + (let ((updates nil)) + (test-pearl--in-org + (format "*** TODO ENG-1 Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: %s\n:LINEAR-DESC-UPDATED-AT: old\n:END:\nEdited body now.\n" + (secure-hash 'sha256 "baseline remote")) + (test-pearl--with-sync-stubs '(:description "baseline remote" :updated-at "t0") updates + (pearl-sync-current-issue) + ;; the pushed markdown is the org body rendered back to md + (should (equal (list (pearl--org-to-md "Edited body now.")) + updates)) + ;; provenance advanced to the pushed content + the push timestamp + (should (string= (secure-hash 'sha256 (pearl--org-to-md "Edited body now.")) + (org-entry-get nil "LINEAR-DESC-SHA256"))) + (should (string= "2026-05-23T02:00:00.000Z" + (org-entry-get nil "LINEAR-DESC-UPDATED-AT"))))))) + +(ert-deftest test-pearl-sync-current-issue-conflict-refuses () + "Local edit + remote also changed: refuse, do not push, keep provenance." + (let ((updates nil) + (stored (secure-hash 'sha256 "baseline remote"))) + (test-pearl--in-org + (format "*** TODO ENG-1 Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-DESC-SHA256: %s\n:END:\nEdited body now.\n" + stored) + (test-pearl--with-sync-stubs '(:description "remote changed too" :updated-at "t1") updates + ;; On conflict the command now prompts; cancel preserves the old + ;; refuse-and-keep-provenance behavior. + (cl-letf (((symbol-function 'pearl--read-conflict-resolution) + (lambda (_label) 'cancel))) + (pearl-sync-current-issue) + (should-not updates) + ;; provenance untouched when the conflict is cancelled + (should (string= stored (org-entry-get nil "LINEAR-DESC-SHA256")))))))) + +(ert-deftest test-pearl-sync-current-issue-not-on-issue-errors () + "Running the command outside a Linear issue heading signals a user error." + (test-pearl--in-org + "* Just a plain heading\nno linear id here\n" + (should-error (pearl-sync-current-issue) :type 'user-error))) + +(provide 'test-pearl-sync) +;;; test-pearl-sync.el ends here diff --git a/tests/test-pearl-teams.el b/tests/test-pearl-teams.el new file mode 100644 index 0000000..dc7e41c --- /dev/null +++ b/tests/test-pearl-teams.el @@ -0,0 +1,109 @@ +;;; test-pearl-teams.el --- Tests for pearl team/project lookups -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for team, project, member, and label lookups with `request' stubbed. +;; These exercise the response-unwrapping (assoc nesting) and the +;; name-to-id resolution used when syncing org headings back to Linear. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) + +;;; pearl-get-teams-async + +(ert-deftest test-pearl-get-teams-async-parses-nodes () + "Teams are unwrapped from data.teams.nodes and passed to the callback." + (let ((got nil) + (pearl--cache-teams nil)) + (testutil-linear-with-response + '((data (teams (nodes . (((id . "t1") (name . "Eng")) + ((id . "t2") (name . "Ops"))))))) + (pearl-get-teams-async (lambda (teams) (setq got teams)))) + (should (= 2 (length got))) + (should (string-equal "Eng" (cdr (assoc 'name (car got))))))) + +;;; pearl--get-team-id-by-name + +(ert-deftest test-pearl-get-team-id-by-name-found () + "A team whose name matches resolves to its id." + (let ((pearl--cache-teams nil)) + (testutil-linear-with-response + '((data (teams (nodes . (((id . "t1") (name . "Eng"))))))) + (should (string-equal "t1" (pearl--get-team-id-by-name "Eng")))))) + +(ert-deftest test-pearl-get-team-id-by-name-not-found () + "A name with no matching team resolves to nil." + (let ((pearl--cache-teams nil)) + (testutil-linear-with-response + '((data (teams (nodes . (((id . "t1") (name . "Eng"))))))) + (should (null (pearl--get-team-id-by-name "Marketing")))))) + +(ert-deftest test-pearl-team-id-lookup-caches-teams () + "A second team-id lookup reuses the cached team list, no new request." + (let ((pearl-api-key "test-key") + (pearl--cache-teams nil) + (calls 0)) + (cl-letf (((symbol-function 'request) + (lambda (_url &rest args) + (setq calls (1+ calls)) + (funcall (plist-get args :success) + :data '((data (teams (nodes . (((id . "t1") (name . "Eng")) + ((id . "t2") (name . "Ops"))))))))) )) + (should (string-equal "t1" (pearl--get-team-id-by-name "Eng"))) + (should (string-equal "t2" (pearl--get-team-id-by-name "Ops"))) + (should (= 1 calls))))) + +;;; pearl-get-projects + +(ert-deftest test-pearl-get-projects-converts-vector-to-list () + "Projects come back as a vector from json-read and are returned as a list." + (testutil-linear-with-response + '((data (team (projects (nodes . [((id . "p1") (name . "Platform"))]))))) + (let ((projects (pearl-get-projects "team-1"))) + (should (listp projects)) + (should (= 1 (length projects))) + (should (string-equal "Platform" (cdr (assoc 'name (car projects)))))))) + +;;; pearl-get-issue-types + +(ert-deftest test-pearl-get-issue-types-maps-name-to-id () + "Issue-type labels are returned as a name -> id alist." + (testutil-linear-with-response + '((data (team (labels (nodes . (((id . "l1") (name . "bug")) + ((id . "l2") (name . "feature")))))))) + (let ((types (pearl-get-issue-types "team-1"))) + (should (string-equal "l1" (cdr (assoc "bug" types)))) + (should (string-equal "l2" (cdr (assoc "feature" types))))))) + +;;; pearl-get-team-members + +(ert-deftest test-pearl-get-team-members-prefers-display-name () + "Members map their display name (falling back to name) to their id." + (testutil-linear-with-response + '((data (team (members (nodes . (((id . "m1") (name . "Ada Lovelace") (displayName . "Ada")) + ((id . "m2") (name . "Alan Turing")))))))) + (let ((members (pearl-get-team-members "team-1"))) + (should (string-equal "m1" (cdr (assoc "Ada" members)))) + (should (string-equal "m2" (cdr (assoc "Alan Turing" members))))))) + +(provide 'test-pearl-teams) +;;; test-pearl-teams.el ends here diff --git a/tests/test-pearl-title-sync.el b/tests/test-pearl-title-sync.el new file mode 100644 index 0000000..6fbd284 --- /dev/null +++ b/tests/test-pearl-title-sync.el @@ -0,0 +1,165 @@ +;;; test-pearl-title-sync.el --- Tests for title sync-back -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for explicit title sync-back, a separate path from the description +;; sync that shares the `pearl--sync-decision' gate. Covers the title +;; extractor, the title fetch and update helpers (stubbed at the HTTP +;; boundary), the command's no-op / push / conflict branches, and the +;; deliberate bracket-stripping lossiness: a bracketed remote title renders +;; with its stored hash matching the stripped heading, so a no-op sync makes +;; no API call and never clobbers the brackets on Linear. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +(defmacro test-pearl--in-org (content &rest body) + "Run BODY in an org-mode temp buffer holding CONTENT, default mapping bound." + (declare (indent 1)) + `(let ((pearl-state-to-todo-mapping + '(("Todo" . "TODO") ("In Progress" . "IN-PROGRESS") ("Done" . "DONE"))) + (org-todo-keywords '((sequence "TODO" "IN-PROGRESS" "|" "DONE")))) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +;;; --issue-title-at-point + +(ert-deftest test-pearl-issue-title-strips-keyword-and-cookie () + "The title extractor returns the heading text without TODO, priority, tags." + (test-pearl--in-org + "*** TODO [#B] My issue title :tag:\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\n" + (should (string= "My issue title" (pearl--issue-title-at-point))))) + +;;; network helpers + +(ert-deftest test-pearl-fetch-issue-title-parses-payload () + "The title fetch returns the remote title and timestamp." + (testutil-linear-with-response + '((data (issue (title . "Remote title") (updatedAt . "2026-05-23T00:00:00.000Z")))) + (let (result) + (pearl--fetch-issue-title-async "a" (lambda (r) (setq result r))) + (should (string= "Remote title" (plist-get result :title))) + (should (string= "2026-05-23T00:00:00.000Z" (plist-get result :updated-at)))))) + +(ert-deftest test-pearl-update-issue-title-success () + "A successful title issueUpdate reports success." + (testutil-linear-with-response + '((data (issueUpdate (success . t) + (issue (id . "a") (updatedAt . "2026-05-23T01:00:00.000Z"))))) + (let (result) + (pearl--update-issue-title-async "a" "New" (lambda (r) (setq result r))) + (should (eq t (plist-get result :success)))))) + +(ert-deftest test-pearl-update-issue-title-soft-fail () + "A non-success title issueUpdate reports failure rather than erroring." + (testutil-linear-with-response + '((data (issueUpdate (success . :json-false) (issue . nil)))) + (let ((called nil) result) + (pearl--update-issue-title-async "a" "New" (lambda (r) (setq called t result r))) + (should called) + (should-not (plist-get result :success))))) + +;;; command branches + +(defmacro test-pearl--with-title-stubs (remote-title update-spy &rest body) + "Run BODY with the title fetch/update helpers stubbed. +REMOTE-TITLE is the plist the fetch hands its callback. UPDATE-SPY collects +the titles pushed to the update helper, which reports success." + (declare (indent 2)) + `(cl-letf (((symbol-function 'pearl--fetch-issue-title-async) + (lambda (_id cb) (funcall cb ,remote-title))) + ((symbol-function 'pearl--update-issue-title-async) + (lambda (_id title cb) + (push title ,update-spy) + (funcall cb '(:success t :updated-at "2026-05-23T02:00:00.000Z"))))) + ,@body)) + +(ert-deftest test-pearl-sync-title-noop-skips-network () + "No title edit: neither the fetch nor the update helper is called." + (let ((fetched nil) (updates nil)) + (test-pearl--in-org + (format "*** TODO [#B] Same Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TITLE-SHA256: %s\n:END:\n" + (secure-hash 'sha256 "Same Title")) + (cl-letf (((symbol-function 'pearl--fetch-issue-title-async) + (lambda (&rest _) (setq fetched t))) + ((symbol-function 'pearl--update-issue-title-async) + (lambda (&rest _) (push 'called updates)))) + (pearl-sync-current-issue-title) + (should-not fetched) + (should-not updates))))) + +(ert-deftest test-pearl-sync-title-push-advances-provenance () + "An edited title against an unchanged remote pushes and advances the hash." + (let ((updates nil)) + (test-pearl--in-org + (format "*** TODO [#B] Edited Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TITLE-SHA256: %s\n:END:\n" + (secure-hash 'sha256 "Old Title")) + (test-pearl--with-title-stubs '(:title "Old Title" :updated-at "t0") updates + (pearl-sync-current-issue-title) + (should (equal '("Edited Title") updates)) + (should (string= (secure-hash 'sha256 "Edited Title") + (org-entry-get nil "LINEAR-TITLE-SHA256"))))))) + +(ert-deftest test-pearl-sync-title-conflict-refuses () + "Title edited locally and changed on the remote too: refuse, do not push." + (let ((updates nil) + (stored (secure-hash 'sha256 "Old Title"))) + (test-pearl--in-org + (format "*** TODO [#B] Edited Title\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TITLE-SHA256: %s\n:END:\n" + stored) + (test-pearl--with-title-stubs '(:title "Remote Changed Title" :updated-at "t1") updates + ;; On conflict the command now prompts; cancel keeps the old behavior. + (cl-letf (((symbol-function 'pearl--read-conflict-resolution) + (lambda (_label) 'cancel))) + (pearl-sync-current-issue-title) + (should-not updates) + (should (string= stored (org-entry-get nil "LINEAR-TITLE-SHA256")))))))) + +(ert-deftest test-pearl-sync-title-bracketed-remote-is-noop () + "A bracketed remote title renders stripped; a no-op sync makes no API call. +This is the deliberate bracket-stripping lossiness: the stored hash is of the +stripped heading, so an unedited bracketed title is never clobbered on Linear." + (let ((fetched nil) (updates nil)) + (test-pearl--in-org + ;; remote title "Fix [URGENT] bug" renders to heading "Fix URGENT bug"; + ;; the stored hash is of the stripped form. + (format "*** TODO [#B] Fix URGENT bug\n:PROPERTIES:\n:LINEAR-ID: a\n:LINEAR-TITLE-SHA256: %s\n:END:\n" + (secure-hash 'sha256 "Fix URGENT bug")) + (cl-letf (((symbol-function 'pearl--fetch-issue-title-async) + (lambda (&rest _) (setq fetched t))) + ((symbol-function 'pearl--update-issue-title-async) + (lambda (&rest _) (push 'called updates)))) + (pearl-sync-current-issue-title) + (should-not fetched) + (should-not updates))))) + +(ert-deftest test-pearl-sync-title-not-on-issue-errors () + "Running the command outside a Linear issue heading signals a user error." + (test-pearl--in-org "* Plain heading\nno id\n" + (should-error (pearl-sync-current-issue-title) :type 'user-error))) + +(provide 'test-pearl-title-sync) +;;; test-pearl-title-sync.el ends here diff --git a/tests/test-pearl-views.el b/tests/test-pearl-views.el new file mode 100644 index 0000000..2a5d6bd --- /dev/null +++ b/tests/test-pearl-views.el @@ -0,0 +1,130 @@ +;;; test-pearl-views.el --- Tests for Linear Custom Views -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Tests for reading and running Linear Custom Views: the cached views list, +;; the server-side `--query-view-async' run, `pearl-run-view', the view +;; branch of refresh, and opening the active view in the browser. HTTP is +;; stubbed. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'testutil-request (expand-file-name "testutil-request.el")) +(require 'cl-lib) + +;;; --query-view-async + +(ert-deftest test-pearl-query-view-async-extracts-issues () + "Running a view extracts the server-side issue nodes into an ok result." + (testutil-linear-with-response + '((data (customView + (issues (nodes . [((id . "i1") (identifier . "ENG-1") (title . "A"))]) + (pageInfo (hasNextPage . :json-false) (endCursor . nil)))))) + (let (result) + (pearl--query-view-async "view-1" (lambda (r) (setq result r))) + (should (eq 'ok (pearl--query-result-status result))) + (should (= 1 (length (pearl--query-result-issues result))))))) + +;;; --custom-views (cached) + +(ert-deftest test-pearl-custom-views-caches () + "The views list is fetched once and served from cache." + (let ((pearl-api-key "test-key") + (pearl--cache-views nil) + (calls 0)) + (cl-letf (((symbol-function 'request) + (lambda (_url &rest args) + (cl-incf calls) + (funcall (plist-get args :success) :data + '((data (customViews + (nodes . [((id . "v1") (name . "My View") (url . "https://x"))]) + (pageInfo (hasNextPage . :json-false))))))))) + (let ((views (pearl--custom-views))) + (should (= 1 (length views))) + (pearl--custom-views) + (should (= 1 calls)))))) + +;;; run-view + +(ert-deftest test-pearl-run-view-renders-with-view-source () + "Running a view resolves its id and renders with a view-typed source." + (let ((ran-id nil) (rendered-source nil)) + (cl-letf (((symbol-function 'pearl--custom-views) + (lambda (&optional _force) + '(((id . "v1") (name . "My View") (url . "https://linear.app/view/v1"))))) + ((symbol-function 'pearl--query-view-async) + (lambda (id cb) (setq ran-id id) + (funcall cb (pearl--make-query-result 'ok :issues nil)))) + ((symbol-function 'pearl--render-query-result) + (lambda (_result source) (setq rendered-source source)))) + (pearl-run-view "My View") + (should (string= "v1" ran-id)) + (should (eq 'view (plist-get rendered-source :type))) + (should (string= "v1" (plist-get rendered-source :id))) + (should (string= "https://linear.app/view/v1" (plist-get rendered-source :url)))))) + +;;; refresh-current-view, view branch + +(ert-deftest test-pearl-refresh-current-view-runs-view-source () + "Refresh on a view source calls the view query, not the filter query." + (let ((view-ran nil) + (source '(:type view :name "My View" :id "v1" :url "https://x"))) + (with-temp-buffer + (insert (format "#+title: Linear — My View\n#+LINEAR-SOURCE: %s\n\n" + (prin1-to-string source))) + (org-mode) + (cl-letf (((symbol-function 'pearl--query-view-async) + (lambda (id cb) (setq view-ran id) + (funcall cb (pearl--make-query-result 'ok :issues nil)))) + ((symbol-function 'pearl--merge-query-result) + (lambda (&rest _) nil))) + (pearl-refresh-current-view) + (should (string= "v1" view-ran)))))) + +;;; open-current-view-in-linear + +(ert-deftest test-pearl-open-current-view-visits-url () + "Opening the active view visits the source's url." + (let ((visited nil) + (source '(:type view :name "My View" :id "v1" :url "https://linear.app/view/v1"))) + (with-temp-buffer + (insert (format "#+LINEAR-SOURCE: %s\n" (prin1-to-string source))) + (org-mode) + (cl-letf (((symbol-function 'browse-url) (lambda (u &rest _) (setq visited u)))) + (pearl-open-current-view-in-linear) + (should (string= "https://linear.app/view/v1" visited)))))) + +(ert-deftest test-pearl-open-current-view-no-url-errors () + "Opening a non-view or url-less source signals a user error." + (let ((source '(:type filter :name "My open issues" :filter (:assignee :me)))) + (with-temp-buffer + (insert (format "#+LINEAR-SOURCE: %s\n" (prin1-to-string source))) + (org-mode) + (should-error (pearl-open-current-view-in-linear) :type 'user-error)))) + +;;; the view query fetches comments too + +(ert-deftest test-pearl-view-issues-query-requests-comments () + "The Custom View query selects comments, so a view-populated list shows them." + (should (string-match-p "comments[[:space:]]*{[[:space:]]*nodes" pearl--view-issues-query))) + +(provide 'test-pearl-views) +;;; test-pearl-views.el ends here diff --git a/tests/testutil-fixtures.el b/tests/testutil-fixtures.el new file mode 100644 index 0000000..5c55c7b --- /dev/null +++ b/tests/testutil-fixtures.el @@ -0,0 +1,105 @@ +;;; testutil-fixtures.el --- representative Linear API response fixtures -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;; Author: Craig Jennings <c@cjennings.net> + +;;; Commentary: + +;; Small, representative response fixtures for the issue-query and +;; representation build. They cover an assignedIssues page, a top-level +;; issues(filter:) page, custom views, a custom view's issues, an issue with +;; comments, and an issue with null/missing optional fields. +;; +;; Shapes mirror what `json-read' returns from the live API: symbol-keyed +;; alists, `t' / `:json-false' for JSON booleans, and a missing key (rather +;; than an explicit value) for absent optional fields. Not a test file (no +;; `test-' prefix), so the suite runner ignores it; tests `require' it. +;; +;; These let normalization, query, and render tests run against stable +;; inputs without a live workspace. Captured from the documented schema +;; shapes; replace with real recorded responses once a live key is wired in. + +;;; Code: + +(defun testutil-linear-fixture-issue-full () + "A fully-populated issue node, every optional field present." + '((id . "uuid-1") + (identifier . "ENG-42") + (title . "Fix the thing") + (description . "Line one\nLine two") + (priority . 2) + (updatedAt . "2026-05-20T12:00:00.000Z") + (state . ((id . "state-1") (name . "In Progress") (type . "started") (color . "#fff"))) + (assignee . ((id . "user-1") (name . "Craig") (email . "c@example.com"))) + (team . ((id . "team-1") (key . "ENG") (name . "Engineering"))) + (project . ((id . "proj-1") (name . "Platform"))) + (cycle . ((id . "cycle-1") (number . 12) (name . "Cycle 12"))) + (labels . ((nodes . (((id . "lbl-1") (name . "bug")) + ((id . "lbl-2") (name . "backend")))))))) + +(defun testutil-linear-fixture-issue-null-fields () + "An issue with optional fields absent or null (project/labels/assignee/cycle). +Description is JSON null; labels is an empty connection." + '((id . "uuid-2") + (identifier . "ENG-7") + (title . "Bare issue") + (description) + (priority . 0) + (updatedAt . "2026-05-19T08:30:00.000Z") + (state . ((id . "state-2") (name . "Todo") (type . "unstarted"))) + (assignee) + (team . ((id . "team-1") (key . "ENG") (name . "Engineering"))) + (project) + (cycle) + (labels . ((nodes . ()))))) + +(defun testutil-linear-fixture-assigned-issues-page () + "A viewer.assignedIssues page: two issues, no next page." + `((data (viewer (assignedIssues + (nodes . (,(testutil-linear-fixture-issue-full) + ,(testutil-linear-fixture-issue-null-fields))) + (pageInfo (hasNextPage . :json-false) (endCursor . "cursor-1"))))))) + +(defun testutil-linear-fixture-issues-filter-page () + "A top-level issues(filter:) page: one issue, has a next page." + `((data (issues + (nodes . (,(testutil-linear-fixture-issue-full))) + (pageInfo (hasNextPage . t) (endCursor . "cursor-2")))))) + +(defun testutil-linear-fixture-custom-views () + "A customViews connection: one shared workspace view, one personal team view." + '((data (customViews + (nodes . (((id . "cv-1") (name . "My open work") (description . "Everything open assigned to me") + (shared . :json-false) (team) (icon . "Inbox") (color . "#aabbcc") + (owner . ((id . "user-1") (name . "Craig")))) + ((id . "cv-2") (name . "Eng in progress") (description) + (shared . t) (team . ((id . "team-1") (key . "ENG") (name . "Engineering"))) + (icon) (color) + (owner . ((id . "user-1") (name . "Craig")))))) + (pageInfo (hasNextPage . :json-false) (endCursor . "cv-cursor")))))) + +(defun testutil-linear-fixture-custom-view-issues () + "A customView(id).issues page: the view's filter resolved server-side." + `((data (customView + (id . "cv-1") + (name . "My open work") + (issues + (nodes . (,(testutil-linear-fixture-issue-full))) + (pageInfo (hasNextPage . :json-false) (endCursor . "cvi-cursor"))))))) + +(defun testutil-linear-fixture-issue-with-comments () + "An issue carrying a comments connection, oldest first." + `((id . "uuid-1") + (identifier . "ENG-42") + (title . "Fix the thing") + (description . "Body text") + (comments (nodes . (((id . "cm-1") (body . "First comment") + (createdAt . "2026-05-18T09:00:00.000Z") + (user . ((id . "user-2") (name . "Alice")))) + ((id . "cm-2") (body . "Second comment, **bold**") + (createdAt . "2026-05-19T10:30:00.000Z") + (user . ((id . "user-1") (name . "Craig"))))))))) + +(provide 'testutil-fixtures) +;;; testutil-fixtures.el ends here diff --git a/tests/testutil-request.el b/tests/testutil-request.el new file mode 100644 index 0000000..a517bb6 --- /dev/null +++ b/tests/testutil-request.el @@ -0,0 +1,49 @@ +;;; testutil-request.el --- request mocking helpers for pearl tests -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Craig Jennings + +;;; Commentary: + +;; Shared helpers for stubbing the `request' library at the HTTP boundary. +;; A stub invokes the package's own :success or :error callback synchronously +;; with canned, json-read-shaped data, so the response-parsing and callback +;; logic runs for real without any network. Not a test file itself (no +;; test- prefix), so the suite runner ignores it; test files `require' it. + +;;; Code: + +(require 'cl-lib) + +(defun testutil-linear-request-success (data) + "Return a `request' replacement that invokes its :success callback with DATA." + (lambda (_url &rest args) + (let ((cb (plist-get args :success))) + (when cb (funcall cb :data data))))) + +(defun testutil-linear-request-error (msg) + "Return a `request' replacement that invokes its :error callback with MSG. +The :response carries a real `request-response' struct, matching what the +live library passes, so the package's status-code logging doesn't choke." + (lambda (_url &rest args) + (let ((cb (plist-get args :error))) + (when cb + (funcall cb :error-thrown msg + :response (make-request-response :status-code 500) + :data nil))))) + +(defmacro testutil-linear-with-response (data &rest body) + "Run BODY with `request' stubbed to succeed with DATA and an API key set." + (declare (indent 1)) + `(let ((pearl-api-key "test-key")) + (cl-letf (((symbol-function 'request) (testutil-linear-request-success ,data))) + ,@body))) + +(defmacro testutil-linear-with-error (msg &rest body) + "Run BODY with `request' stubbed to fail with MSG and an API key set." + (declare (indent 1)) + `(let ((pearl-api-key "test-key")) + (cl-letf (((symbol-function 'request) (testutil-linear-request-error ,msg))) + ,@body))) + +(provide 'testutil-request) +;;; testutil-request.el ends here |