diff options
| -rw-r--r-- | pearl.el | 147 | ||||
| -rw-r--r-- | tests/test-pearl-bugfixes.el | 155 |
2 files changed, 255 insertions, 47 deletions
@@ -367,8 +367,6 @@ If SUCCESS-FN or ERROR-FN are not provided, default handlers will be used." (when variables (pearl--log "Variables: %s" (prin1-to-string variables))) - (setq pearl--active-requests (1+ pearl--active-requests)) - (unless success-fn (setq success-fn (lambda (data) (pearl--log "Request completed: %s" (prin1-to-string data))))) @@ -379,13 +377,18 @@ If SUCCESS-FN or ERROR-FN are not provided, default handlers will be used." (pearl--log "Error response: %s" (prin1-to-string data))))) (let ((request-data (json-encode `(("query" . ,query) - ,@(when variables `(("variables" . ,variables))))))) + ,@(when variables `(("variables" . ,variables)))))) + ;; Build headers before bumping the counter: `pearl--headers' signals + ;; when the API key is unset, and that must happen before the increment + ;; or no callback ever runs to decrement it (leaking the count). + (headers (pearl--headers))) (pearl--log "Request payload: %s" request-data) + (setq pearl--active-requests (1+ pearl--active-requests)) (request pearl-graphql-url :type "POST" - :headers (pearl--headers) + :headers headers :data request-data :parser 'json-read :success (cl-function @@ -1508,7 +1511,9 @@ Gives immediate feedback and performs the API update in the background." (selected (when project-names (completing-read "Select project (optional): " (cons "None" project-names) nil t nil nil "None")))) - (unless (string= selected "None") + ;; Guard the nil case explicitly: a team with no projects (or a failed + ;; fetch) leaves SELECTED nil, so only consult the choice when one was made. + (when (and selected (not (string= selected "None"))) (cdr (assoc selected project-names))))) ;;; Other Issue Attributes @@ -2299,6 +2304,29 @@ Callers wrap this in `save-excursion' when they must not move point." (unless (ignore-errors (org-back-to-heading t) t) (user-error "%s" (or message "Not on a Linear issue heading")))) +(defun pearl--issue-id-at-point () + "Return the `LINEAR-ID' of the issue heading enclosing point, or nil. +Climbs ancestors: from inside a comment subtree (a heading carrying +`LINEAR-COMMENT-ID' but no `LINEAR-ID') it walks up to the issue heading. Does +not move point or signal." + (save-excursion + (when (ignore-errors (org-back-to-heading t) t) + (while (and (not (org-entry-get nil "LINEAR-ID")) + (org-up-heading-safe))) + (org-entry-get nil "LINEAR-ID")))) + +(defun pearl--goto-issue-heading-or-error () + "Move point to the enclosing issue heading (one carrying `LINEAR-ID'), or error. +The guard for issue-scoped commands that must work from anywhere inside an +issue subtree, including from a comment heading or body: it climbs out of the +comment to the issue heading. Signals a `user-error' when no ancestor heading +carries `LINEAR-ID'." + (pearl--goto-heading-or-error) + (while (and (not (org-entry-get nil "LINEAR-ID")) + (org-up-heading-safe))) + (unless (org-entry-get nil "LINEAR-ID") + (user-error "Not on a Linear issue heading"))) + ;;;###autoload (defun pearl-sync-current-issue () "Push the description edited in the Org body of the issue at point to Linear. @@ -2366,18 +2394,19 @@ buffer) so the refresh can't silently lose them (decision 4), then the refresh proceeds and the subtree is replaced with Linear's version." (interactive) (save-excursion - (pearl--goto-heading-or-error) + (pearl--goto-issue-heading-or-error) (let ((issue-id (org-entry-get nil "LINEAR-ID")) - (stored (org-entry-get nil "LINEAR-DESC-SHA256")) (marker (point-marker))) - (unless issue-id - (user-error "Not on a Linear issue heading")) - (let ((local-md (pearl--org-to-md (pearl--issue-body-at-point)))) - ;; Stash an unpushed edit before the overwrite rather than refusing, - ;; so an explicit single-issue refresh always proceeds without data loss. - (unless (string= (secure-hash 'sha256 local-md) (or stored "")) + (progn + ;; Stash an unpushed edit before the overwrite rather than refusing, so + ;; an explicit single-issue refresh always proceeds without data loss. + ;; Use the Org-hash-first dirty check (`pearl--subtree-dirty-p') so a + ;; clean description whose markdown is lossy under org->md isn't falsely + ;; flagged dirty and stashed -- the same fix the merge refresh uses. + (when (pearl--subtree-dirty-p) (pearl--stash-conflict-text - (format "%s description (pre-refresh)" issue-id) local-md)) + (format "%s description (pre-refresh)" issue-id) + (pearl--org-to-md (pearl--issue-body-at-point)))) (pearl--progress "Refreshing %s from Linear..." issue-id) (pearl--fetch-issue-async issue-id @@ -2502,11 +2531,9 @@ cancels. An alternative to editing the description inline for anyone who wants a dedicated buffer. Works from anywhere inside an issue subtree." (interactive) (save-excursion - (pearl--goto-heading-or-error) + (pearl--goto-issue-heading-or-error) (let ((issue-id (org-entry-get nil "LINEAR-ID")) (marker (point-marker))) - (unless issue-id - (user-error "Not on a Linear issue heading")) (pearl--compose-in-buffer (format "description for %s" issue-id) pearl--compose-description-instructions @@ -2523,7 +2550,7 @@ Reads the `LINEAR-URL' property of the enclosing issue heading and hands it to `browse-url'. Works from anywhere inside the issue subtree." (interactive) (let ((url (save-excursion - (pearl--goto-heading-or-error) + (pearl--goto-issue-heading-or-error) (org-entry-get nil "LINEAR-URL")))) (unless (and url (not (string-empty-p url))) (user-error "No LINEAR-URL on the issue at point")) @@ -2646,12 +2673,10 @@ anywhere inside an issue subtree." (interactive (list (completing-read "Priority: " pearl--priority-choices nil t))) (save-excursion - (pearl--goto-heading-or-error) + (pearl--goto-issue-heading-or-error) (let ((issue-id (org-entry-get nil "LINEAR-ID")) (priority-num (cdr (assoc priority-name pearl--priority-choices))) (marker (point-marker))) - (unless issue-id - (user-error "Not on a Linear issue heading")) (unless priority-num (user-error "Unknown priority: %s" priority-name)) (pearl--push-issue-field @@ -2689,7 +2714,7 @@ success. Works from anywhere inside an issue subtree." (and team-id (pearl--team-states team-id))) nil t)))) (save-excursion - (pearl--goto-heading-or-error) + (pearl--goto-issue-heading-or-error) (let* ((issue-id (org-entry-get nil "LINEAR-ID")) (team-id (org-entry-get nil "LINEAR-TEAM-ID")) (marker (point-marker)) @@ -2726,7 +2751,7 @@ anywhere inside an issue subtree." (pearl--team-collection-names 'members team-id) nil t)))) (save-excursion - (pearl--goto-heading-or-error) + (pearl--goto-issue-heading-or-error) (let* ((issue-id (org-entry-get nil "LINEAR-ID")) (team-id (org-entry-get nil "LINEAR-TEAM-ID")) (marker (point-marker)) @@ -2759,7 +2784,7 @@ issue subtree." "Labels (comma-separated, empty to clear): " (pearl--team-collection-names 'labels team-id))))) (save-excursion - (pearl--goto-heading-or-error) + (pearl--goto-issue-heading-or-error) (let* ((issue-id (org-entry-get nil "LINEAR-ID")) (team-id (org-entry-get nil "LINEAR-TEAM-ID")) (marker (point-marker)) @@ -2967,6 +2992,10 @@ active file with the query recorded as the source." (order (plist-get spec :order)) (source (list :type 'filter :name name :filter filter-plist :sort sort :order order))) + ;; Validate the saved query's authoring plist at the command boundary so + ;; a typo'd key or bad value surfaces as a clear user-error instead of + ;; being silently dropped or failing deeper in the compiler. + (pearl--validate-issue-filter filter-plist) (pearl--progress "Running saved query %s..." name) (pearl--query-issues-async (pearl--build-issue-filter filter-plist) @@ -3044,6 +3073,9 @@ filter; SAVE-NAME, when given, persists it via `pearl--save-query'." (list (pearl--read-filter-interactively) (when (y-or-n-p "Save as a local query? ") (read-string "Query name: ")))) + ;; Validate before saving or running, so a bad filter never gets persisted + ;; or run -- the command boundary is where the clear error belongs. + (pearl--validate-issue-filter filter-plist) (when (and save-name (not (string-empty-p save-name))) (pearl--save-query save-name filter-plist)) (let ((source (list :type 'filter @@ -3366,7 +3398,9 @@ only the viewer's own comments are saved through the gate." (let* ((comment-id (org-entry-get nil "LINEAR-COMMENT-ID")) (author-id (org-entry-get nil "LINEAR-COMMENT-AUTHOR-ID")) (spec (list - :issue-id (org-entry-get nil "LINEAR-ID") + ;; Comment headings carry LINEAR-COMMENT-ID, not LINEAR-ID, so + ;; climb to the enclosing issue for the outcome's :issue-id. + :issue-id (pearl--issue-id-at-point) :identifier comment-id :field 'comment :comment-id comment-id :marker marker :prop "LINEAR-COMMENT-SHA256" :local (pearl--org-to-md (pearl--issue-body-at-point)) @@ -3479,9 +3513,7 @@ is saved sequentially through its conflict gate and a single summary is reported. A clean issue does no network at all." (interactive) (save-excursion - (pearl--goto-heading-or-error) - (unless (org-entry-get nil "LINEAR-ID") - (user-error "Not on a Linear issue heading")) + (pearl--goto-issue-heading-or-error) (let* ((marker (point-marker)) (buffer (current-buffer)) (dirty (pearl--issue-dirty-fields))) @@ -3513,22 +3545,29 @@ wait for the next save (each field's content is still re-read at push)." (push (cons marker dirty) result)))) (nreverse result))) -(defun pearl--save-all-counts (scan viewer-id) +(defun pearl--save-all-counts (scan viewer-id &optional viewer-failed) "Tally the dirty fields in SCAN, classifying comments with VIEWER-ID. -Returns a plist (:issues :titles :descriptions :own-comments -:read-only-comments)." - (let ((issues 0) (titles 0) (descriptions 0) (own 0) (read-only 0)) +When VIEWER-FAILED is non-nil (the viewer lookup ran and failed), every comment +candidate counts as `:viewer-unavailable' rather than being classified as own / +read-only -- a nil VIEWER-ID then means \"couldn't tell\", not \"none are +yours\". Returns a plist (:issues :titles :descriptions :own-comments +:read-only-comments :viewer-unavailable)." + (let ((issues 0) (titles 0) (descriptions 0) (own 0) (read-only 0) + (viewer-unavailable 0)) (dolist (cell scan) (let ((dirty (cdr cell))) (setq issues (1+ issues)) (when (plist-get dirty :title) (setq titles (1+ titles))) (when (plist-get dirty :description) (setq descriptions (1+ descriptions))) - (let ((split (pearl--classify-comment-candidates - (plist-get dirty :comment-candidates) viewer-id))) - (setq own (+ own (length (plist-get split :own)))) - (setq read-only (+ read-only (length (plist-get split :read-only))))))) + (let ((cands (plist-get dirty :comment-candidates))) + (if viewer-failed + (setq viewer-unavailable (+ viewer-unavailable (length cands))) + (let ((split (pearl--classify-comment-candidates cands viewer-id))) + (setq own (+ own (length (plist-get split :own)))) + (setq read-only (+ read-only (length (plist-get split :read-only))))))))) (list :issues issues :titles titles :descriptions descriptions - :own-comments own :read-only-comments read-only))) + :own-comments own :read-only-comments read-only + :viewer-unavailable viewer-unavailable))) (defun pearl--save-all-prompt (counts) "Return the one-time confirmation prompt string for the dirty COUNTS plist." @@ -3536,30 +3575,39 @@ Returns a plist (:issues :titles :descriptions :own-comments (descriptions (plist-get counts :descriptions)) (own (plist-get counts :own-comments)) (read-only (plist-get counts :read-only-comments)) + (viewer-unavailable (or (plist-get counts :viewer-unavailable) 0)) (fields (+ titles descriptions own)) (issues (plist-get counts :issues)) - parts) + parts skips) (when (> titles 0) (push (format "%d title%s" titles (if (= titles 1) "" "s")) parts)) (when (> descriptions 0) (push (format "%d description%s" descriptions (if (= descriptions 1) "" "s")) parts)) (when (> own 0) (push (format "%d comment%s" own (if (= own 1) "" "s")) parts)) + (when (> read-only 0) + (push (format "%d read-only comment%s" read-only (if (= read-only 1) "" "s")) skips)) + (when (> viewer-unavailable 0) + (push (format "%d comment%s (viewer unavailable)" + viewer-unavailable (if (= viewer-unavailable 1) "" "s")) + skips)) (format "Save %d field%s across %d issue%s? (%s%s) " fields (if (= fields 1) "" "s") issues (if (= issues 1) "" "s") (if parts (string-join (nreverse parts) ", ") "0 fields") - (if (> read-only 0) - (format "; %d read-only comment%s skipped" - read-only (if (= read-only 1) "" "s")) + (if skips + (concat "; " (string-join (nreverse skips) ", ") " skipped") "")))) -(defun pearl--save-all-run (scan buffer viewer-id) +(defun pearl--save-all-run (scan buffer viewer-id &optional viewer-failed) "Confirm SCAN once, then save all its dirty fields and report. -VIEWER-ID gates comment ownership; BUFFER is surfaced if anything pushed. -Declining the prompt mutates nothing. The queue continues past a per-field -conflict, so one conflicted ticket does not stop the rest." - (if (not (y-or-n-p (pearl--save-all-prompt (pearl--save-all-counts scan viewer-id)))) +VIEWER-ID gates comment ownership; VIEWER-FAILED marks a failed viewer lookup so +the prompt counts comments as viewer-unavailable rather than read-only. BUFFER +is surfaced if anything pushed. Declining the prompt mutates nothing. The +queue continues past a per-field conflict, so one conflicted ticket does not +stop the rest." + (if (not (y-or-n-p (pearl--save-all-prompt + (pearl--save-all-counts scan viewer-id viewer-failed)))) (message "save-all cancelled; nothing saved") (let (thunks) (dolist (cell scan) @@ -3591,7 +3639,11 @@ reported. A clean file does nothing." (if (and has-comments (not pearl--cache-viewer)) (pearl--viewer-async (lambda (viewer) - (pearl--save-all-run scan buffer (and viewer (plist-get viewer :id))))) + ;; A nil viewer here means the lookup failed (we only do it when + ;; comments exist), so flag it -- those comments are + ;; viewer-unavailable, not read-only. + (pearl--save-all-run scan buffer (and viewer (plist-get viewer :id)) + (null viewer)))) (pearl--save-all-run scan buffer (and pearl--cache-viewer (plist-get pearl--cache-viewer :id)))))))) @@ -3770,6 +3822,7 @@ how each issue's state renders as a TODO keyword." (pearl--progress "Fetching issues from Linear...") (let* ((authoring `(:assignee :me :open t ,@(when project-id (list :project project-id)))) + (_ (pearl--validate-issue-filter authoring)) (source (list :type 'filter :name (if project-id "My open issues in project" "My open issues") :filter authoring)) diff --git a/tests/test-pearl-bugfixes.el b/tests/test-pearl-bugfixes.el new file mode 100644 index 0000000..7f5c635 --- /dev/null +++ b/tests/test-pearl-bugfixes.el @@ -0,0 +1,155 @@ +;;; test-pearl-bugfixes.el --- Tests for the 2026-05-25 quick bug batch -*- 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 a batch of small bugs found in a 2026-05-25 code review of +;; pearl.el (each was a :bug:quick:solo: todo): single-issue refresh +;; false-stash, comment outcome parent-issue-id, save-all viewer-unavailable +;; counting, request-counter leak on a missing key, issue commands climbing +;; out of comment subtrees, the project selector on no projects, and +;; command-path filter validation. + +;;; Code: + +(require 'test-bootstrap (expand-file-name "test-bootstrap.el")) +(require 'cl-lib) + +(defmacro test-pearl-bug--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"))) + (pearl-state-to-todo-mapping '(("Todo" . "TODO"))) + (org-element-use-cache nil)) + (with-temp-buffer + (insert ,content) + (org-mode) + (goto-char (point-min)) + ,@body))) + +;;; Bug: single-issue refresh falsely stashes clean lossy descriptions + +(ert-deftest test-pearl-refresh-clean-lossy-description-not-stashed () + "A freshly rendered issue whose markdown is lossy under org->md is not stashed." + (test-pearl-bug--in-org + (pearl--format-issue-as-org-entry + '(:id "u" :identifier "ENG-1" :title "t" :priority 3 + :state (:name "Todo") :description "# Heading\nbody text")) + (re-search-forward "body text") + (let ((stashed nil)) + (cl-letf (((symbol-function 'pearl--stash-conflict-text) + (lambda (&rest _) (setq stashed t))) + ((symbol-function 'pearl--fetch-issue-async) + (lambda (&rest _) nil))) + (pearl-refresh-current-issue) + (should-not stashed))))) + +;;; Bug: comment save outcomes lose the parent issue id + +(ert-deftest test-pearl-issue-id-at-point-climbs-from-comment () + "From inside a comment subtree, the enclosing issue's LINEAR-ID is found." + (test-pearl-bug--in-org + (concat "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + "**** Comments\n***** Me\n:PROPERTIES:\n:LINEAR-COMMENT-ID: c1\n:END:\nhi\n") + (re-search-forward "^\\*\\*\\*\\*\\* Me") + (should (string= "a" (pearl--issue-id-at-point))))) + +(ert-deftest test-pearl-save-comment-outcome-carries-issue-id () + "A skipped comment outcome carries the enclosing issue id, not nil." + (test-pearl-bug--in-org + (concat "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + "**** Comments\n***** Other\n:PROPERTIES:\n:LINEAR-COMMENT-ID: c1\n" + ":LINEAR-COMMENT-AUTHOR-ID: u-other\n:END:\nhi\n") + (re-search-forward "^\\*\\*\\*\\*\\* Other") + (let (outcome) + ;; non-own comment -> skipped/read-only, no network; outcome should still + ;; name the parent issue. + (pearl--save-comment-field (point-marker) "u-me" + (lambda (o) (setq outcome o))) + (should (string= "a" (plist-get outcome :issue-id)))))) + +;;; Bug: save-all prompt mislabels viewer-lookup failures as read-only + +(ert-deftest test-pearl-save-all-counts-viewer-failed-not-read-only () + "With the viewer lookup failed, comment candidates count as viewer-unavailable." + (let* ((scan (list (cons (make-marker) + (list :title nil :description nil + :comment-candidates + '((:comment-id "c1" :author-id "u-me")))))) + (counts (pearl--save-all-counts scan nil t))) + (should (= 0 (plist-get counts :read-only-comments))) + (should (= 0 (plist-get counts :own-comments))) + (should (= 1 (plist-get counts :viewer-unavailable))) + (should (string-match-p "viewer unavailable" (pearl--save-all-prompt counts))))) + +;;; Bug: missing API key can leak the active request count + +(ert-deftest test-pearl-request-missing-key-does-not-leak-counter () + "A missing key signals before dispatch and leaves the request counter intact." + (let ((pearl-api-key nil) + (pearl--active-requests 0)) + (should-error (pearl--graphql-request-async "query { viewer { id } }")) + (should (= 0 pearl--active-requests)))) + +;;; Bug: issue-level commands do not climb out of comment subtrees + +(ert-deftest test-pearl-goto-issue-heading-climbs-from-comment () + "The issue-heading guard climbs from a comment to the enclosing issue heading." + (test-pearl-bug--in-org + (concat "*** TODO Title\n:PROPERTIES:\n:LINEAR-ID: a\n:END:\nBody.\n" + "**** Comments\n***** Me\n:PROPERTIES:\n:LINEAR-COMMENT-ID: c1\n:END:\nhi\n") + (re-search-forward "^\\*\\*\\*\\*\\* Me") + (pearl--goto-issue-heading-or-error) + (should (string= "a" (org-entry-get nil "LINEAR-ID"))))) + +(ert-deftest test-pearl-goto-issue-heading-errors-off-an-issue () + "With no enclosing issue heading, the guard signals a user-error." + (test-pearl-bug--in-org "* Plain heading\nno linear id\n" + (goto-char (point-max)) + (should-error (pearl--goto-issue-heading-or-error) :type 'user-error))) + +;;; Bug: project selector errors when a team has no projects + +(ert-deftest test-pearl-select-project-no-projects-returns-nil () + "With no projects (or a failed fetch), the selector returns nil without erroring." + (cl-letf (((symbol-function 'pearl-get-projects) (lambda (_team) nil))) + (should (null (pearl-select-project "team-1"))))) + +;;; Bug: saved/ad-hoc query filters bypass validation + +(ert-deftest test-pearl-run-saved-query-validates-before-fetch () + "A saved query with an unknown filter key errors before any fetch." + (let ((pearl-saved-queries '(("bad" :filter (:bogus-key "x")))) + (fetched nil)) + (cl-letf (((symbol-function 'pearl--query-issues-async) + (lambda (&rest _) (setq fetched t)))) + (should-error (pearl-run-saved-query "bad") :type 'user-error) + (should-not fetched)))) + +(ert-deftest test-pearl-run-saved-query-validates-bad-priority () + "A saved query with an out-of-range priority errors before any fetch." + (let ((pearl-saved-queries '(("bad" :filter (:priority 9)))) + (fetched nil)) + (cl-letf (((symbol-function 'pearl--query-issues-async) + (lambda (&rest _) (setq fetched t)))) + (should-error (pearl-run-saved-query "bad") :type 'user-error) + (should-not fetched)))) + +(provide 'test-pearl-bugfixes) +;;; test-pearl-bugfixes.el ends here |