diff options
| -rw-r--r-- | modules/dev-fkeys.el | 81 | ||||
| -rw-r--r-- | tests/test-dev-fkeys--projectile-around-revert.el | 79 | ||||
| -rw-r--r-- | tests/test-dev-fkeys--projectile-capture-cmd.el | 28 |
3 files changed, 138 insertions, 50 deletions
diff --git a/modules/dev-fkeys.el b/modules/dev-fkeys.el index 836b7cf6..0b973470 100644 --- a/modules/dev-fkeys.el +++ b/modules/dev-fkeys.el @@ -175,26 +175,40 @@ a single Compile entry that calls plain `compile'." ;; the three projectile cmd-runners reverts the cache to its prior value ;; if the compile fails AND the cmd was modified. A test that fails ;; because of a real code bug (cmd unchanged) leaves the cache alone. +;; Revert state is captured before Projectile runs, then closed over by a +;; buffer-local compilation finish hook so overlapping compiles cannot +;; overwrite or consume one another's revert metadata. (defvar cj/--projectile-revert-state nil - "Plist describing the projectile cache state to potentially revert. -Set by `cj/--projectile-capture-cmd' before each invocation; read and -cleared by `cj/--projectile-revert-on-fail' after the compile finishes. -Keys: :map (cmd-map symbol), :root (project root), :prior (cached cmd -before invocation, may be nil).") + "Legacy dynamic state used by direct tests of `cj/--projectile-revert-on-fail'. +The around advice no longer stores live compile metadata here; it closes +over the plist returned by `cj/--projectile-capture-cmd' instead.") (defun cj/--projectile-capture-cmd (map-symbol) "Capture the cached cmd at the project root in MAP-SYMBOL. MAP-SYMBOL is the symbol of a projectile cmd-map (e.g. -`projectile-compile-cmd-map'). Stashes a plist in -`cj/--projectile-revert-state' for the finish hook to read. No-op when -the project root cannot be resolved or MAP-SYMBOL is unbound (projectile -not loaded)." +`projectile-compile-cmd-map'). Return nil when the project root cannot +be resolved or MAP-SYMBOL is unbound (projectile not loaded)." (let ((root (cj/--f4-project-root))) (when (and root (boundp map-symbol)) (let ((prior (gethash root (symbol-value map-symbol)))) - (setq cj/--projectile-revert-state - (list :map map-symbol :root root :prior prior)))))) + (list :map map-symbol :root root :prior prior))))) + +(defun cj/--projectile-revert-state-on-fail (state status) + "Apply projectile cache revert STATE when STATUS is a failed compile. +Reverts the cmd-map entry only when the compile failed AND the cmd was +modified from the captured prior value AND that prior was non-nil. The +unchanged-and-failed case (test fails because of a real bug) leaves the +cache alone." + (when (and state (stringp status) + (not (string-prefix-p "finished" status))) + (let* ((map (plist-get state :map)) + (root (plist-get state :root)) + (prior (plist-get state :prior)) + (current (and (boundp map) (gethash root (symbol-value map))))) + (when (and root prior (boundp map) + (not (equal prior current))) + (puthash root prior (symbol-value map)))))) (defun cj/--projectile-revert-on-fail (_buf status) "Compilation-finish hook: revert projectile cache on failed-and-modified. @@ -206,24 +220,41 @@ because of a real bug) leaves the cache alone." (remove-hook 'compilation-finish-functions #'cj/--projectile-revert-on-fail) (let ((state cj/--projectile-revert-state)) (setq cj/--projectile-revert-state nil) - (when (and state (stringp status) - (not (string-prefix-p "finished" status))) - (let* ((map (plist-get state :map)) - (root (plist-get state :root)) - (prior (plist-get state :prior)) - (current (and (boundp map) (gethash root (symbol-value map))))) - (when (and root prior (boundp map) - (not (equal prior current))) - (puthash root prior (symbol-value map))))))) + (cj/--projectile-revert-state-on-fail state status))) + +(defun cj/--projectile-make-revert-on-fail-hook (state) + "Return a one-shot buffer-local finish hook for projectile revert STATE." + (let (hook) + (setq hook + (lambda (buf status) + (when (buffer-live-p buf) + (with-current-buffer buf + (remove-hook 'compilation-finish-functions hook t))) + (cj/--projectile-revert-state-on-fail state status))) + hook)) + +(defun cj/--projectile-compilation-buffer (result) + "Return the compilation buffer represented by RESULT, or nil." + (cond + ((bufferp result) result) + ((processp result) (process-buffer result)) + (t nil))) (defun cj/--projectile-around-revert (map-symbol orig-fn &rest args) "Around-advice for projectile cmd-runners. MAP-SYMBOL identifies which cmd-map to capture (compile / test / run). -Captures the prior cached cmd, installs the one-shot revert-on-failure -hook, then invokes ORIG-FN with ARGS." - (cj/--projectile-capture-cmd map-symbol) - (add-hook 'compilation-finish-functions #'cj/--projectile-revert-on-fail) - (apply orig-fn args)) +Captures the prior cached cmd, invokes ORIG-FN with ARGS, then installs a +one-shot buffer-local revert-on-failure hook on the returned compilation +buffer when possible." + (let* ((state (cj/--projectile-capture-cmd map-symbol)) + (result (apply orig-fn args)) + (buffer (cj/--projectile-compilation-buffer result))) + (when (and state (buffer-live-p buffer)) + (with-current-buffer buffer + (add-hook 'compilation-finish-functions + (cj/--projectile-make-revert-on-fail-hook state) + nil t))) + result)) (defun cj/projectile-reset-cmds () "Clear projectile's cached compile/test/run cmds for the current project. diff --git a/tests/test-dev-fkeys--projectile-around-revert.el b/tests/test-dev-fkeys--projectile-around-revert.el index bdcb11a1..012c4258 100644 --- a/tests/test-dev-fkeys--projectile-around-revert.el +++ b/tests/test-dev-fkeys--projectile-around-revert.el @@ -33,29 +33,81 @@ (should (equal calls '((arg1 arg2)))))) (ert-deftest test-dev-fkeys-projectile-around-revert-captures-prior () - "Normal: advice captures the prior cmd into the revert state." + "Normal: advice captures the prior cmd into the buffer-local hook." (let ((cj/--projectile-revert-state nil) (compilation-finish-functions nil) (projectile-compile-cmd-map (make-hash-table :test 'equal))) (puthash "/p/" "make build" projectile-compile-cmd-map) (cl-letf (((symbol-function 'cj/--f4-project-root) (lambda () "/p/"))) - (cj/--projectile-around-revert - 'projectile-compile-cmd-map - (lambda (&rest _) nil))) - (should (equal (plist-get cj/--projectile-revert-state :prior) - "make build")))) + (let ((compile-buffer (get-buffer-create " *compile-capture*"))) + (unwind-protect + (progn + (cj/--projectile-around-revert + 'projectile-compile-cmd-map + (lambda (&rest _) compile-buffer)) + (puthash "/p/" "make typo" projectile-compile-cmd-map) + (with-current-buffer compile-buffer + (run-hook-with-args 'compilation-finish-functions + compile-buffer "exited abnormally\n")) + (should (equal (gethash "/p/" projectile-compile-cmd-map) + "make build"))) + (kill-buffer compile-buffer)))))) (ert-deftest test-dev-fkeys-projectile-around-revert-installs-finish-hook () - "Normal: advice adds the revert-on-fail hook to compilation-finish-functions." + "Normal: advice adds a buffer-local revert hook to the compilation buffer." (let ((cj/--projectile-revert-state nil) (compilation-finish-functions nil) (projectile-compile-cmd-map (make-hash-table :test 'equal))) + (puthash "/p/" "make build" projectile-compile-cmd-map) (cl-letf (((symbol-function 'cj/--f4-project-root) (lambda () "/p/"))) - (cj/--projectile-around-revert - 'projectile-compile-cmd-map - (lambda (&rest _) nil))) - (should (member #'cj/--projectile-revert-on-fail - compilation-finish-functions)))) + (with-current-buffer (get-buffer-create " *compile-a*") + (setq-local compilation-finish-functions nil)) + (unwind-protect + (let ((compile-buffer + (cj/--projectile-around-revert + 'projectile-compile-cmd-map + (lambda (&rest _) (get-buffer-create " *compile-a*"))))) + (should-not compilation-finish-functions) + (with-current-buffer compile-buffer + (should compilation-finish-functions))) + (kill-buffer " *compile-a*"))))) + +(ert-deftest test-dev-fkeys-projectile-around-revert-overlapping-compiles-use-own-state () + "Regression: overlapping compiles finishing out of order use their own state." + (let ((cj/--projectile-revert-state nil) + (compilation-finish-functions nil) + (projectile-compile-cmd-map (make-hash-table :test 'equal)) + (roots '("/one/" "/two/"))) + (puthash "/one/" "make one" projectile-compile-cmd-map) + (puthash "/two/" "make two" projectile-compile-cmd-map) + (cl-letf (((symbol-function 'cj/--f4-project-root) + (lambda () (pop roots)))) + (let ((buf-one (get-buffer-create " *compile-one*")) + (buf-two (get-buffer-create " *compile-two*"))) + (unwind-protect + (progn + (cj/--projectile-around-revert + 'projectile-compile-cmd-map + (lambda (&rest _) buf-one)) + (cj/--projectile-around-revert + 'projectile-compile-cmd-map + (lambda (&rest _) buf-two)) + (puthash "/one/" "make one typo" projectile-compile-cmd-map) + (puthash "/two/" "make two typo" projectile-compile-cmd-map) + (with-current-buffer buf-two + (run-hook-with-args 'compilation-finish-functions + buf-two "exited abnormally\n")) + (should (string= (gethash "/two/" projectile-compile-cmd-map) + "make two")) + (should (string= (gethash "/one/" projectile-compile-cmd-map) + "make one typo")) + (with-current-buffer buf-one + (run-hook-with-args 'compilation-finish-functions + buf-one "exited abnormally\n")) + (should (string= (gethash "/one/" projectile-compile-cmd-map) + "make one"))) + (kill-buffer buf-one) + (kill-buffer buf-two)))))) ;;; Boundary Cases @@ -70,7 +122,8 @@ The state stays nil so the finish hook will be a no-op too." 'projectile-compile-cmd-map (lambda (&rest _) (cl-incf calls)))) (should (= calls 1)) - (should (null cj/--projectile-revert-state)))) + (should (null cj/--projectile-revert-state)) + (should-not compilation-finish-functions))) (provide 'test-dev-fkeys--projectile-around-revert) ;;; test-dev-fkeys--projectile-around-revert.el ends here diff --git a/tests/test-dev-fkeys--projectile-capture-cmd.el b/tests/test-dev-fkeys--projectile-capture-cmd.el index 92309198..bc4c7684 100644 --- a/tests/test-dev-fkeys--projectile-capture-cmd.el +++ b/tests/test-dev-fkeys--projectile-capture-cmd.el @@ -2,9 +2,9 @@ ;;; Commentary: ;; Tests for the prior-cmd capture helper used by the auto-revert advice. -;; Captures the current cached cmd at the project root into -;; `cj/--projectile-revert-state' so a later finish-hook can restore it -;; if the compile fails after the cmd was modified. +;; Captures the current cached cmd at the project root into a plist so a +;; later finish-hook can restore it if the compile fails after the cmd was +;; modified. ;;; Code: @@ -24,25 +24,29 @@ (ert-deftest test-dev-fkeys-projectile-capture-cmd-stores-prior-value () "Normal: captures the cached cmd at the project root into the state plist." (let* ((cj/--projectile-revert-state nil) - (projectile-compile-cmd-map (make-hash-table :test 'equal))) + (projectile-compile-cmd-map (make-hash-table :test 'equal)) + state) (puthash "/p/" "make build" projectile-compile-cmd-map) (cl-letf (((symbol-function 'cj/--f4-project-root) (lambda () "/p/"))) - (cj/--projectile-capture-cmd 'projectile-compile-cmd-map)) - (should (equal (plist-get cj/--projectile-revert-state :map) + (setq state (cj/--projectile-capture-cmd 'projectile-compile-cmd-map))) + (should (equal (plist-get state :map) 'projectile-compile-cmd-map)) - (should (equal (plist-get cj/--projectile-revert-state :root) "/p/")) - (should (equal (plist-get cj/--projectile-revert-state :prior) "make build")))) + (should (equal (plist-get state :root) "/p/")) + (should (equal (plist-get state :prior) "make build")) + (should (null cj/--projectile-revert-state)))) (ert-deftest test-dev-fkeys-projectile-capture-cmd-no-prior-stores-nil () "Normal: when no cmd is cached, captures :prior nil — distinct from \"didn't capture at all\" because :map and :root are still set." (let* ((cj/--projectile-revert-state nil) - (projectile-test-cmd-map (make-hash-table :test 'equal))) + (projectile-test-cmd-map (make-hash-table :test 'equal)) + state) (cl-letf (((symbol-function 'cj/--f4-project-root) (lambda () "/p/"))) - (cj/--projectile-capture-cmd 'projectile-test-cmd-map)) - (should (eq (plist-get cj/--projectile-revert-state :map) + (setq state (cj/--projectile-capture-cmd 'projectile-test-cmd-map))) + (should (eq (plist-get state :map) 'projectile-test-cmd-map)) - (should (null (plist-get cj/--projectile-revert-state :prior))))) + (should (null (plist-get state :prior))) + (should (null cj/--projectile-revert-state)))) ;;; Boundary Cases |