diff options
Diffstat (limited to 'lisp/emacs-lisp/ert.el')
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 244 |
1 files changed, 195 insertions, 49 deletions
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 02551bad31f..c57bd0a69e2 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -328,8 +328,8 @@ DATA is displayed to the user and should state the reason for skipping." (unless (eql ,value ',default-value) (list :value ,value)) (unless (eql ,value ',default-value) - (when-let ((-explainer- - (ert--get-explainer ',fn-name))) + (when-let* ((-explainer- + (ert--get-explainer ',fn-name))) (list :explanation (apply -explainer- ,args))))) value) @@ -576,7 +576,7 @@ Return nil if they are." (defun ert--significant-plist-keys (plist) "Return the keys of PLIST that have non-null values, in order." - (cl-assert (zerop (mod (length plist) 2)) t) + (cl-assert (evenp (length plist)) t) (cl-loop for (key value . rest) on plist by #'cddr unless (or (null value) (memq key accu)) collect key into accu finally (cl-return accu))) @@ -587,8 +587,8 @@ Return nil if they are." Returns nil if they are equivalent, i.e., have the same value for each key, where absent values are treated as nil. The order of key/value pairs in each list does not matter." - (cl-assert (zerop (mod (length a) 2)) t) - (cl-assert (zerop (mod (length b) 2)) t) + (cl-assert (evenp (length a)) t) + (cl-assert (evenp (length b)) t) ;; Normalizing the plists would be another way to do this but it ;; requires a total ordering on all lisp objects (since any object ;; is valid as a text property key). Perhaps defining such an @@ -1159,21 +1159,21 @@ Also changes the counters in STATS to match." (aref results pos)) (cl-etypecase (aref results pos) (ert-test-passed - (cl-incf (ert--stats-passed-expected stats) d)) + (incf (ert--stats-passed-expected stats) d)) (ert-test-failed - (cl-incf (ert--stats-failed-expected stats) d)) + (incf (ert--stats-failed-expected stats) d)) (ert-test-skipped - (cl-incf (ert--stats-skipped stats) d)) + (incf (ert--stats-skipped stats) d)) (null) (ert-test-aborted-with-non-local-exit) (ert-test-quit)) (cl-etypecase (aref results pos) (ert-test-passed - (cl-incf (ert--stats-passed-unexpected stats) d)) + (incf (ert--stats-passed-unexpected stats) d)) (ert-test-failed - (cl-incf (ert--stats-failed-unexpected stats) d)) + (incf (ert--stats-failed-unexpected stats) d)) (ert-test-skipped - (cl-incf (ert--stats-skipped stats) d)) + (incf (ert--stats-skipped stats) d)) (null) (ert-test-aborted-with-non-local-exit) (ert-test-quit))))) @@ -1316,13 +1316,9 @@ empty string." (defun ert--pp-with-indentation-and-newline (object) "Pretty-print OBJECT, indenting it to the current column of point. Ensures a final newline is inserted." - (let ((begin (point)) - (cols (current-column)) - (pp-escape-newlines t) + (let ((pp-escape-newlines t) (print-escape-control-characters t)) - (pp object (current-buffer)) - (unless (bolp) (insert "\n")) - (indent-rigidly begin (point) cols))) + (pp object (current-buffer)))) (defun ert--insert-infos (result) "Insert `ert-info' infos from RESULT into current buffer. @@ -1356,10 +1352,10 @@ RESULT must be an `ert-test-result-with-condition'." (defun ert-test-location (test) "Return a string description the source location of TEST." - (when-let ((loc - (ignore-errors - (find-function-search-for-symbol - (ert-test-name test) 'ert-deftest (ert-test-file-name test))))) + (when-let* ((loc + (ignore-errors + (find-function-search-for-symbol + (ert-test-name test) 'ert--test (ert-test-file-name test))))) (let* ((buffer (car loc)) (point (cdr loc)) (file (file-relative-name (buffer-file-name buffer))) @@ -1423,7 +1419,7 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (cl-plusp + (if (plusp (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) @@ -1436,7 +1432,7 @@ Returns the stats object." (message "%9s %S%s" (ert-string-for-test-result result nil) (ert-test-name test) - (if (cl-plusp + (if (plusp (length (getenv "EMACS_TEST_VERBOSE"))) (ert-reason-for-test-result result) "")))) @@ -1552,11 +1548,11 @@ test packages depend on each other, it might be helpful.") "Write a JUnit test report, generated from STATS." ;; https://www.ibm.com/docs/en/developer-for-zos/14.1.0?topic=formats-junit-xml-format ;; https://llg.cubic.org/docs/junit/ - (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) - (test-file (symbol-file symbol 'ert--test)) - (test-report - (file-name-with-extension - (or ert-load-file-name test-file) "xml"))) + (when-let* ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report + (file-name-with-extension + (or ert-load-file-name test-file) "xml"))) (with-temp-file test-report (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") (insert (format "<testsuites name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\">\n" @@ -1688,8 +1684,8 @@ test packages depend on each other, it might be helpful.") (insert " </error>\n" " </testcase>\n" " </testsuite>\n") - (cl-incf errors 1) - (cl-incf id 1))) + (incf errors 1) + (incf id 1))) (insert-file-contents-literally test-report) (when (looking-at-p @@ -1697,15 +1693,15 @@ test packages depend on each other, it might be helpful.") (delete-region (point) (line-beginning-position 2))) (when (looking-at "<testsuites name=\".+\" tests=\"\\(.+\\)\" errors=\"\\(.+\\)\" failures=\"\\(.+\\)\" skipped=\"\\(.+\\)\" time=\"\\(.+\\)\">") - (cl-incf tests (string-to-number (match-string 1))) - (cl-incf errors (string-to-number (match-string 2))) - (cl-incf failures (string-to-number (match-string 3))) - (cl-incf skipped (string-to-number (match-string 4))) - (cl-incf time (string-to-number (match-string 5))) + (incf tests (string-to-number (match-string 1))) + (incf errors (string-to-number (match-string 2))) + (incf failures (string-to-number (match-string 3))) + (incf skipped (string-to-number (match-string 4))) + (incf time (string-to-number (match-string 5))) (delete-region (point) (line-beginning-position 2))) (when (looking-at " <testsuite id=\"\\(0\\)\"") (replace-match (number-to-string id) nil nil nil 1) - (cl-incf id 1)) + (incf id 1)) (goto-char (point-max)) (beginning-of-line 0) (when (looking-at-p "</testsuites>") @@ -2127,7 +2123,7 @@ non-nil, returns the face for expected results.." (defun ert-face-for-stats (stats) "Return a face that represents STATS." (cond ((ert--stats-aborted-p stats) 'nil) - ((cl-plusp (ert-stats-completed-unexpected stats)) + ((plusp (ert-stats-completed-unexpected stats)) (ert-face-for-test-result nil)) ((eql (ert-stats-completed-expected stats) (ert-stats-total stats)) (ert-face-for-test-result t)) @@ -2471,7 +2467,9 @@ To be used in the ERT results buffer." (defun ert--test-name-button-action (button) "Find the definition of the test BUTTON belongs to, in another window." - (let ((name (button-get button 'ert-test-name))) + ;; work with either ert-insert-test-name-button or help-xref-button + (let ((name (or (button-get button 'ert-test-name) + (car (button-get button 'help-args))))) (ert-find-test-other-window name))) (defun ert--ewoc-position (ewoc node) @@ -2818,7 +2816,8 @@ To be used in the ERT results buffer." (file-name-nondirectory file-name))) (save-excursion (re-search-backward (substitute-command-keys "`\\([^`']+\\)'")) - (help-xref-button 1 'help-function-def test-name file-name))) + (help-xref-button 1 'ert--test-name-button + test-name file-name))) (insert ".") (fill-region-as-paragraph (point-min) (point)) (insert "\n\n") @@ -2857,14 +2856,16 @@ To be used in the ERT results buffer." (ert--tests-running-mode-line-indicator)))) (add-hook 'emacs-lisp-mode-hook #'ert--activate-font-lock-keywords) -(defun ert--unload-function () +(defun ert-unload-function () "Unload function to undo the side-effects of loading ert.el." - (ert--remove-from-list 'find-function-regexp-alist 'ert-deftest :key #'car) + (ert--remove-from-list 'find-function-regexp-alist 'ert--test :key #'car) (ert--remove-from-list 'minor-mode-alist 'ert--current-run-stats :key #'car) (ert--remove-from-list 'emacs-lisp-mode-hook 'ert--activate-font-lock-keywords) nil) +;;; erts files. + (defun ert-test-erts-file (file &optional transform) "Parse FILE as a file containing before/after parts (an erts file). @@ -2910,10 +2911,10 @@ write erts files." (setq end-before end-after start-after start-before)) ;; Update persistent specs. - (when-let ((point-char (assq 'point-char specs))) + (when-let* ((point-char (assq 'point-char specs))) (setq gen-specs (map-insert gen-specs 'point-char (cdr point-char)))) - (when-let ((code (cdr (assq 'code specs)))) + (when-let* ((code (cdr (assq 'code specs)))) (setq gen-specs (map-insert gen-specs 'code (car (read-from-string code))))) ;; Get the "after" strings. @@ -2921,12 +2922,12 @@ write erts files." (insert-buffer-substring file-buffer start-after end-after) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-after-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-after-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) ;; Get the expected "after" point. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (goto-char (point-min)) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)) @@ -2937,13 +2938,13 @@ write erts files." (insert-buffer-substring file-buffer start-before end-before) (ert--erts-unquote) ;; Remove the newline at the end of the buffer. - (when-let ((no-newline (cdr (assq 'no-before-newline specs)))) + (when-let* ((no-newline (cdr (assq 'no-before-newline specs)))) (goto-char (point-min)) (when (re-search-forward "\n\\'" nil t) (delete-region (match-beginning 0) (match-end 0)))) (goto-char (point-min)) ;; Place point in the specified place. - (when-let ((point-char (cdr (assq 'point-char gen-specs)))) + (when-let* ((point-char (cdr (assq 'point-char gen-specs)))) (when (search-forward point-char nil t) (delete-region (match-beginning 0) (match-end 0)))) (let ((code (cdr (assq 'code gen-specs)))) @@ -2991,8 +2992,151 @@ write erts files." (forward-line 1))) (nreverse specs)))) -(defvar ert-unload-hook ()) -(add-hook 'ert-unload-hook #'ert--unload-function) + +;;; Buffer related helpers + +(defun ert--text-button (string &rest properties) + "Return a string containing STRING as a text button with PROPERTIES. + +See `make-text-button'." + (with-temp-buffer + (insert string) + (apply #'make-text-button (point-min) (point-max) properties) + (buffer-string))) + +(defun ert--format-test-buffer-name (base-name) + "Compute a test buffer name based on BASE-NAME. + +Helper function for `ert--test-buffers'." + (format "*Test buffer (%s)%s*" + (or (and (ert-running-test) + (ert-test-name (ert-running-test))) + "<anonymous test>") + (if base-name + (format ": %s" base-name) + ""))) + +(defvar ert--test-buffers (make-hash-table :weakness t) + "Table of all test buffers. Keys are the buffer objects, values are t. + +The main use of this table is for `ert-kill-all-test-buffers'. +Not all buffers in this table are necessarily live, but all live +test buffers are in this table.") + +(define-button-type 'ert--test-buffer-button + 'action #'ert--test-buffer-button-action + 'help-echo "mouse-2, RET: Pop to test buffer") + +(defun ert--test-buffer-button-action (button) + "Pop to the test buffer that BUTTON is associated with." + (pop-to-buffer (button-get button 'ert--test-buffer))) + +(defun ert--call-with-test-buffer (ert--base-name ert--thunk) + "Helper function for `ert-with-test-buffer'. + +Create a test buffer with a name based on ERT--BASE-NAME and run +ERT--THUNK with that buffer as current." + (let* ((ert--buffer (generate-new-buffer + (ert--format-test-buffer-name ert--base-name))) + (ert--button (ert--text-button (buffer-name ert--buffer) + :type 'ert--test-buffer-button + 'ert--test-buffer ert--buffer))) + (puthash ert--buffer 't ert--test-buffers) + ;; We don't use `unwind-protect' here since we want to kill the + ;; buffer only on success. + (prog1 (with-current-buffer ert--buffer + (ert-info (ert--button :prefix "Buffer: ") + (funcall ert--thunk))) + (kill-buffer ert--buffer) + (remhash ert--buffer ert--test-buffers)))) + +(cl-defmacro ert-with-test-buffer ((&key ((:name name-form)) + ((:selected select-form))) + &body body) + "Create a test buffer and run BODY in that buffer. + +To be used in ERT tests. If BODY finishes successfully, the test buffer +is killed; if there is an error, the test buffer is kept around for +further inspection. The name of the buffer is derived from the name of +the test and the result of NAME-FORM. + +If SELECT-FORM is non-nil, switch to the test buffer before running +BODY, as if body was in `ert-with-buffer-selected'. + +The return value is the last form in BODY." + (declare (debug ((":name" form) (":selected" form) def-body)) + (indent 1)) + `(ert--call-with-test-buffer + ,name-form + ,(if select-form + `(lambda () (ert-with-buffer-selected (current-buffer) + ,@body)) + `(lambda () ,@body)))) + +(defun ert-kill-all-test-buffers () + "Kill all test buffers that are still live." + (interactive) + (let ((count 0)) + (maphash (lambda (buffer _dummy) + (when (or (not (buffer-live-p buffer)) + (kill-buffer buffer)) + (incf count))) + ert--test-buffers) + (message "%s out of %s test buffers killed" + count (hash-table-count ert--test-buffers))) + ;; It could be that some test buffers were actually kept alive + ;; (e.g., due to `kill-buffer-query-functions'). I'm not sure what + ;; to do about this. For now, let's just forget them. + (clrhash ert--test-buffers) + nil) + +(cl-defmacro ert-with-buffer-selected (buffer-or-name &body body) + "Display a buffer in a temporary selected window and run BODY. + +If BUFFER-OR-NAME is nil, the current buffer is used. + +The buffer is made the current buffer, and the temporary window +becomes the `selected-window', before BODY is evaluated. The +modification hooks `before-change-functions' and +`after-change-functions' are not inhibited during the evaluation +of BODY, which makes it easier to use `execute-kbd-macro' to +simulate user interaction. The window configuration is restored +before returning, even if BODY exits nonlocally. The return +value is the last form in BODY." + (declare (debug (form body)) (indent 1)) + `(save-window-excursion + (with-current-buffer (or ,buffer-or-name (current-buffer)) + (with-selected-window (display-buffer (current-buffer)) + ,@body)))) + +(defun ert-call-with-buffer-renamed (buffer-name thunk) + "Protect the buffer named BUFFER-NAME from side-effects and run THUNK. + +Renames the buffer BUFFER-NAME to a new temporary name, creates a +new buffer named BUFFER-NAME, executes THUNK, kills the new +buffer, and renames the original buffer back to BUFFER-NAME. + +This is useful if THUNK has undesirable side-effects on an Emacs +buffer with a fixed name such as *Messages*." + (let ((new-buffer-name (generate-new-buffer-name + (format "%s orig buffer" buffer-name)))) + (with-current-buffer (get-buffer-create buffer-name) + (rename-buffer new-buffer-name)) + (unwind-protect + (progn + (get-buffer-create buffer-name) + (funcall thunk)) + (when (get-buffer buffer-name) + (kill-buffer buffer-name)) + (with-current-buffer new-buffer-name + (rename-buffer buffer-name))))) + +(cl-defmacro ert-with-buffer-renamed ((buffer-name-form) &body body) + "Protect the buffer named BUFFER-NAME from side-effects and run BODY. + +See `ert-call-with-buffer-renamed' for details." + (declare (indent 1)) + `(ert-call-with-buffer-renamed ,buffer-name-form (lambda () ,@body))) ;;; Obsolete @@ -3001,6 +3145,8 @@ write erts files." (put 'ert-equal-including-properties 'ert-explainer 'ert--explain-equal-including-properties) +(define-obsolete-function-alias 'ert--unload-function 'ert-unload-function "31.1") + (provide 'ert) ;;; ert.el ends here |