diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/ert.el | 232 | ||||
| -rw-r--r-- | lisp/emacs-lisp/multisession.el | 20 |
2 files changed, 128 insertions, 124 deletions
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 597044cf21c..019916e6172 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el @@ -1531,102 +1531,100 @@ the tests)." "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/ - (unless (zerop (length (ert--stats-tests stats))) - (when-let ((test-file - (symbol-file - (ert-test-name (aref (ert--stats-tests stats) 0)) 'ert--test)) - (test-report (file-name-with-extension 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" - (file-name-nondirectory test-report) - (ert-stats-total stats) - (if (ert--stats-aborted-p stats) 1 0) - (ert-stats-completed-unexpected stats) - (ert-stats-skipped stats) - (float-time - (time-subtract - (ert--stats-end-time stats) - (ert--stats-start-time stats))))) - (insert (format " <testsuite id=\"0\" name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\" timestamp=\"%s\">\n" - (file-name-nondirectory test-report) - (ert-stats-total stats) - (if (ert--stats-aborted-p stats) 1 0) - (ert-stats-completed-unexpected stats) - (ert-stats-skipped stats) - (float-time - (time-subtract - (ert--stats-end-time stats) - (ert--stats-start-time stats))) - (ert--format-time-iso8601 (ert--stats-end-time stats)))) - (insert " <properties>\n" - (format " <property name=\"selector\" value=\"%s\"/>\n" - (ert--stats-selector stats)) - " </properties>\n") - (cl-loop for test across (ert--stats-tests stats) - for result = (ert-test-most-recent-result test) do - (insert (format " <testcase name=\"%s\" status=\"%s\" time=\"%s\"" - (xml-escape-string - (symbol-name (ert-test-name test))) - (ert-string-for-test-result - result - (ert-test-result-expected-p test result)) - (ert-test-result-duration result))) - (if (and (ert-test-result-expected-p test result) - (not (ert-test-aborted-with-non-local-exit-p result)) - (not (ert-test-skipped-p result)) - (zerop (length (ert-test-result-messages result)))) - (insert "/>\n") - (insert ">\n") - (cond - ((ert-test-skipped-p result) - (insert (format " <skipped message=\"%s\" type=\"%s\">\n" - (xml-escape-string - (string-trim - (ert-reason-for-test-result result))) - (ert-string-for-test-result - result - (ert-test-result-expected-p - test result))) - (xml-escape-string - (string-trim - (ert-reason-for-test-result result))) - "\n" - " </skipped>\n")) - ((ert-test-aborted-with-non-local-exit-p result) - (insert (format " <error message=\"%s\" type=\"%s\">\n" - (file-name-nondirectory test-report) - (ert-string-for-test-result - result - (ert-test-result-expected-p - test result))) - (format "Test %s aborted with non-local exit\n" - (xml-escape-string - (symbol-name (ert-test-name test)))) - " </error>\n")) - ((not (ert-test-result-type-p - result (ert-test-expected-result-type test))) - (insert (format " <failure message=\"%s\" type=\"%s\">\n" - (xml-escape-string - (string-trim - (ert-reason-for-test-result result))) - (ert-string-for-test-result - result - (ert-test-result-expected-p - test result))) - (xml-escape-string - (string-trim - (ert-reason-for-test-result result))) - "\n" - " </failure>\n"))) - (unless (zerop (length (ert-test-result-messages result))) - (insert " <system-out>\n" - (xml-escape-string - (ert-test-result-messages result)) - " </system-out>\n")) - (insert " </testcase>\n"))) - (insert " </testsuite>\n") - (insert "</testsuites>\n"))))) + (when-let ((symbol (car (apropos-internal "" #'ert-test-boundp))) + (test-file (symbol-file symbol 'ert--test)) + (test-report (file-name-with-extension 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" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))))) + (insert (format " <testsuite id=\"0\" name=\"%s\" tests=\"%s\" errors=\"%s\" failures=\"%s\" skipped=\"%s\" time=\"%s\" timestamp=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-stats-total stats) + (if (ert--stats-aborted-p stats) 1 0) + (ert-stats-completed-unexpected stats) + (ert-stats-skipped stats) + (float-time + (time-subtract + (ert--stats-end-time stats) + (ert--stats-start-time stats))) + (ert--format-time-iso8601 (ert--stats-end-time stats)))) + (insert " <properties>\n" + (format " <property name=\"selector\" value=\"%s\"/>\n" + (ert--stats-selector stats)) + " </properties>\n") + (cl-loop for test across (ert--stats-tests stats) + for result = (ert-test-most-recent-result test) do + (insert (format " <testcase name=\"%s\" status=\"%s\" time=\"%s\"" + (xml-escape-string + (symbol-name (ert-test-name test))) + (ert-string-for-test-result + result + (ert-test-result-expected-p test result)) + (ert-test-result-duration result))) + (if (and (ert-test-result-expected-p test result) + (not (ert-test-aborted-with-non-local-exit-p result)) + (not (ert-test-skipped-p result)) + (zerop (length (ert-test-result-messages result)))) + (insert "/>\n") + (insert ">\n") + (cond + ((ert-test-skipped-p result) + (insert (format " <skipped message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + "\n" + " </skipped>\n")) + ((ert-test-aborted-with-non-local-exit-p result) + (insert (format " <error message=\"%s\" type=\"%s\">\n" + (file-name-nondirectory test-report) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (format "Test %s aborted with non-local exit\n" + (xml-escape-string + (symbol-name (ert-test-name test)))) + " </error>\n")) + ((not (ert-test-result-type-p + result (ert-test-expected-result-type test))) + (insert (format " <failure message=\"%s\" type=\"%s\">\n" + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + (ert-string-for-test-result + result + (ert-test-result-expected-p + test result))) + (xml-escape-string + (string-trim + (ert-reason-for-test-result result))) + "\n" + " </failure>\n"))) + (unless (zerop (length (ert-test-result-messages result))) + (insert " <system-out>\n" + (xml-escape-string + (ert-test-result-messages result)) + " </system-out>\n")) + (insert " </testcase>\n"))) + (insert " </testsuite>\n") + (insert "</testsuites>\n")))) (defun ert-write-junit-test-summary-report (&rest logfiles) "Write a JUnit summary test report, generated from LOGFILES." @@ -1637,24 +1635,30 @@ the tests)." (dolist (logfile logfiles) (let ((test-report (file-name-with-extension logfile "xml"))) (if (not (file-readable-p test-report)) - (let ((logfile (file-name-with-extension logfile "log"))) - (insert (format " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n" - id test-report - (ert--format-time-iso8601 (current-time)))) - (insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n" - (file-name-nondirectory test-report))) - (insert (format " <error message=\"Test report missing %s\" type=\"error\">\n" - (file-name-nondirectory test-report))) - (when (file-readable-p logfile) - (insert (xml-escape-string - (with-temp-buffer - (insert-file-contents-literally logfile) - (buffer-string))))) - (insert " </error>\n" - " </testcase>\n" - " </testsuite>\n") - (cl-incf errors 1) - (cl-incf id 1)) + (let* ((logfile (file-name-with-extension logfile "log")) + (logfile-contents + (when (file-readable-p logfile) + (with-temp-buffer + (insert-file-contents-literally logfile) + (buffer-string))))) + (unless + ;; No defined tests, perhaps a helper file. + (and logfile-contents + (string-match-p "^Running 0 tests" logfile-contents)) + (insert (format " <testsuite id=\"%s\" name=\"%s\" tests=\"1\" errors=\"1\" failures=\"0\" skipped=\"0\" time=\"0\" timestamp=\"%s\">\n" + id test-report + (ert--format-time-iso8601 (current-time)))) + (insert (format " <testcase name=\"Test report missing %s\" status=\"error\" time=\"0\">\n" + (file-name-nondirectory test-report))) + (insert (format " <error message=\"Test report missing %s\" type=\"error\">\n" + (file-name-nondirectory test-report))) + (when logfile-contents + (insert (xml-escape-string logfile-contents))) + (insert " </error>\n" + " </testcase>\n" + " </testsuite>\n") + (cl-incf errors 1) + (cl-incf id 1))) (insert-file-contents-literally test-report) (when (looking-at-p diff --git a/lisp/emacs-lisp/multisession.el b/lisp/emacs-lisp/multisession.el index 17c9384134c..bce888acc68 100644 --- a/lisp/emacs-lisp/multisession.el +++ b/lisp/emacs-lisp/multisession.el @@ -26,7 +26,6 @@ (require 'cl-lib) (require 'eieio) (require 'sqlite) -(require 'url) (require 'tabulated-list) (defcustom multisession-storage 'files @@ -158,7 +157,7 @@ DOC should be a doc string, and ARGS are keywords as applicable to multisession--db "create unique index multisession_idx on multisession (package, key)"))))) -(cl-defmethod multisession-backend-value ((_type (eql sqlite)) object) +(cl-defmethod multisession-backend-value ((_type (eql 'sqlite)) object) (multisession--ensure-db) (let ((id (list (multisession--package object) (multisession--key object)))) @@ -198,7 +197,7 @@ DOC should be a doc string, and ARGS are keywords as applicable to (t (multisession--cached-value object))))) -(cl-defmethod multisession--backend-set-value ((_type (eql sqlite)) +(cl-defmethod multisession--backend-set-value ((_type (eql 'sqlite)) object value) (catch 'done (let ((i 0)) @@ -234,13 +233,13 @@ DOC should be a doc string, and ARGS are keywords as applicable to id))) (setf (multisession--cached-value object) value)))) -(cl-defmethod multisession--backend-values ((_type (eql sqlite))) +(cl-defmethod multisession--backend-values ((_type (eql 'sqlite))) (multisession--ensure-db) (sqlite-select multisession--db "select package, key, value from multisession order by package, key")) -(cl-defmethod multisession--backend-delete ((_type (eql sqlite)) object) +(cl-defmethod multisession--backend-delete ((_type (eql 'sqlite)) object) (sqlite-execute multisession--db "delete from multisession where package = ? and key = ?" (list (multisession--package object) @@ -278,7 +277,7 @@ DOC should be a doc string, and ARGS are keywords as applicable to ".value") multisession-directory)) -(cl-defmethod multisession-backend-value ((_type (eql files)) object) +(cl-defmethod multisession-backend-value ((_type (eql 'files)) object) (let ((file (multisession--object-file-name object))) (cond ;; We have no value yet; see whether it's stored. @@ -301,7 +300,7 @@ DOC should be a doc string, and ARGS are keywords as applicable to (t (multisession--cached-value object))))) -(cl-defmethod multisession--backend-set-value ((_type (eql files)) +(cl-defmethod multisession--backend-set-value ((_type (eql 'files)) object value) (let ((file (multisession--object-file-name object)) (time (current-time))) @@ -322,14 +321,15 @@ DOC should be a doc string, and ARGS are keywords as applicable to ;; file for somewhat better atomicity. (let ((coding-system-for-write 'utf-8) (create-lockfiles nil) - (temp (make-temp-name file))) + (temp (make-temp-name file)) + (write-region-inhibit-fsync nil)) (write-region (point-min) (point-max) temp nil 'silent) (set-file-times temp time) (rename-file temp file t))) (setf (multisession--cached-sequence object) time (multisession--cached-value object) value))) -(cl-defmethod multisession--backend-values ((_type (eql files))) +(cl-defmethod multisession--backend-values ((_type (eql 'files))) (mapcar (lambda (file) (let ((bits (file-name-split file))) (list (url-unhex-string (car (last bits 2))) @@ -343,7 +343,7 @@ DOC should be a doc string, and ARGS are keywords as applicable to (expand-file-name "files" multisession-directory) "\\.value\\'"))) -(cl-defmethod multisession--backend-delete ((_type (eql files)) object) +(cl-defmethod multisession--backend-delete ((_type (eql 'files)) object) (let ((file (multisession--object-file-name object))) (when (file-exists-p file) (delete-file file)))) |