diff --git a/.gitignore b/.gitignore index b3dc6faf1decd5644e6aba6507323dd94e73008f..3102daeb17721f501a0d0afcd570c71d21b44cb5 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ *.lib /docs/ +/build/ diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3cf552fff040c77175b9bc401379714904c8e2f0..298907fe345f2dad0ea9094aa7919a67ee72662a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -24,6 +24,12 @@ workflow: - if: '$CI_COMMIT_BRANCH' - if: '$CI_COMMIT_TAG' +# Upload test report +.common:test:clci: + artifacts: + reports: + junit: build/junit.xml + # Build the docs and upload them to Gitlab. generate docs: extends: diff --git a/clpmfile.lock b/clpmfile.lock index 27e6988a2113c95c5199c9756a8b5b529d63fe40..e2614cc65c72c5cd2bdbaf79dc19c732f50e53e9 100644 --- a/clpmfile.lock +++ b/clpmfile.lock @@ -180,6 +180,7 @@ ("which" :version "2016-04-21" :source "quicklisp" :systems ("which")) ("xml-emitter" :version "2020-02-18" :source "quicklisp" :systems ("xml-emitter")) +("xmls" :version "2018-04-30" :source "quicklisp" :systems ("xmls")) ("xsubseq" :version "2017-08-30" :source "quicklisp" :systems ("xsubseq")) ("zip" :version "2015-06-08" :source "quicklisp" :systems ("zip")) @@ -526,6 +527,8 @@ ("xml-emitter" (t (:system :name "xml-emitter"))) +("xmls" ((:system :name "tar-file/test") (:system :name "xmls"))) + ("xsubseq" ((:system :name "smart-buffer") (:system :name "xsubseq")) ((:system :name "fast-http") (:system :name "xsubseq"))) diff --git a/tar-file.asd b/tar-file.asd index 400f461296c1d884ca41b6296d8510f95ade1c51..547353f17ba73f1c9ba289d0f3442dd0fb6ee235 100644 --- a/tar-file.asd +++ b/tar-file.asd @@ -13,7 +13,9 @@ :perform (test-op (o c) (unless (eql :passed (uiop:symbol-call :parachute :status - (uiop:symbol-call :parachute :test :tar-file-test))) + (uiop:symbol-call :parachute :test :tar-file-test + :report (uiop:find-symbol* :plain-junit-report :tar-file-test) + :pathname (asdf:system-relative-pathname "tar-file" "build/junit.xml")))) (error "Tests failed"))) :components ((:file "blocked-stream" :depends-on ("package")) (:file "bounded-stream" :depends-on ("package")) @@ -44,6 +46,7 @@ :components ((:file "blocked-stream" :depends-on ("package")) (:file "package") (:file "read" :depends-on ("package")) + (:file "report" :depends-on ("package")) (:file "shared" :depends-on ("package")) (:file "write" :depends-on ("package"))) - :depends-on (#:tar-file #:parachute)) + :depends-on (#:tar-file #:parachute #:xmls)) diff --git a/test/blocked-stream.lisp b/test/blocked-stream.lisp index b04dc6dda99e0c516d5493155555a0a1e32c6a6c..9999715e699897499792d2fb3c175e8ddef9507e 100644 --- a/test/blocked-stream.lisp +++ b/test/blocked-stream.lisp @@ -6,7 +6,10 @@ :initial-element 0) s)) +(para:define-test blocked-stream) + (para:define-test blocked-output-stream + :parent blocked-stream (dolist (block-size '(512 1024 2048)) (uiop:with-temporary-file (:stream raw-stream :pathname pn :element-type '(unsigned-byte 8)) @@ -20,11 +23,12 @@ (para:is = block-size (file-length raw-stream)) (para:is = (char-code #\a) (read-byte raw-stream)) (let ((seq (make-array block-size :element-type '(unsigned-byte 8) - :initial-element 0))) + :initial-element 0))) (read-sequence seq raw-stream) (para:true (every #'zerop seq))))))) (para:define-test blocked-input-stream + :parent blocked-stream (uiop:with-temporary-file (:stream raw-stream :pathname pn :element-type '(unsigned-byte 8)) (write-test-file raw-stream (char-code #\a) 1024) @@ -42,6 +46,7 @@ (para:is eql :eof (read-byte s nil :eof)))))) (para:define-test blocked-input-stream-set-file-position + :parent blocked-stream (uiop:with-temporary-file (:stream raw-stream :pathname pn :element-type '(unsigned-byte 8)) (write-test-file raw-stream (char-code #\a) 1024) @@ -61,6 +66,7 @@ (para:is eql :eof (read-byte s nil :eof)))))) (para:define-test blocked-input-stream-set-file-position-2 + :parent blocked-stream (uiop:with-temporary-file (:stream raw-stream :pathname pn :element-type '(unsigned-byte 8)) (write-test-file raw-stream (char-code #\a) 1024) @@ -80,6 +86,7 @@ (para:is = (char-code #\a) (read-byte s)))))) (para:define-test jumping-across-blocks + :parent blocked-stream (uiop:with-temporary-file (:stream raw-stream :pathname pn :element-type '(unsigned-byte 8)) (write-sequence (make-array 1024 :element-type '(unsigned-byte 8) @@ -109,6 +116,7 @@ (para:true (every (lambda (x) (= x 1)) seq))))))) (para:define-test bounded-stream-jumping-across-blocks + :parent blocked-stream (uiop:with-temporary-file (:stream raw-stream :pathname pn :element-type '(unsigned-byte 8)) (write-sequence (make-array 1024 :element-type '(unsigned-byte 8) diff --git a/test/report.lisp b/test/report.lisp new file mode 100644 index 0000000000000000000000000000000000000000..977681c4579b10f166c1616b7b2d29975f9e444f --- /dev/null +++ b/test/report.lisp @@ -0,0 +1,88 @@ +(in-package #:tar-file-test) + +(defclass junit-report (para:report) + ((pathname + :initarg :pathname))) + +(defclass plain-junit-report (junit-report para:plain) + ()) + +(defvar *processed-results*) + +(defun duration-to-xml (duration) + (format nil "~f" duration)) + +(defgeneric make-junit-node (result &key class-name)) + +(defmethod make-junit-node ((result para:test-result) &key class-name) + (let* ((child-test-results (remove-if-not (lambda (x) (typep x 'para:test-result)) + (para:results result))) + (child-results (remove-if (lambda (x) (typep x 'para:test-result)) + (para:results result))) + (num-tests (length child-results)) + (num-failures (count :failed child-results :key 'para:status)) + (num-skipped (count :skipped child-results :key 'para:status)) + (name (result-name result)) + (class-name (format nil "~@[~a.~]~a" class-name name))) + (xmls:make-node + :name "testsuite" + :attrs `(("name" ,name) + ("tests" ,num-tests) + ("failures" ,num-failures) + ("errors" 0) + ("skipped" ,num-skipped) + ("time" ,(duration-to-xml (para:duration result)))) + :children + (append + (map 'list + (lambda (x) (make-junit-node x :class-name class-name)) + child-test-results) + (map 'list (lambda (x) (make-junit-node x :class-name class-name)) + child-results))))) + +(defun result-name (result) + (let ((expression (para:expression result))) + (if (typep expression 'para:test) + (para:name expression) + (format nil "~a" expression)))) + +(defmethod make-junit-node ((result para:result) &key class-name) + (xmls:make-node + :name "testcase" + :attrs `(("classname" ,class-name) + ("name" ,(result-name result)) + ("time" ,(duration-to-xml (para:duration result)))) + :child (ecase (para:status result) + (:passed + nil) + (:skipped + (xmls:make-node :name "skipped")) + (:failure + (xmls:make-node :name "failure"))))) + +(defmethod make-junit-node :after (result &key class-name) + (declare (ignore class-name)) + (setf (gethash result *processed-results*) t)) + +(defun result-is-suite-p (result) + (and (typep result 'para:test-result) + (some (lambda (x) (typep x '(and para:result (not para:test-result)))) + (para:results result)))) + +(defmethod para:summarize ((report junit-report)) + (let ((*processed-results* (make-hash-table)) + (pathname (slot-value report 'pathname))) + (ensure-directories-exist pathname) + (with-open-file (s pathname :direction :output :if-exists :supersede) + (xmls:write-xml + (xmls:make-node :name "testsuites" + :children + (loop + :for result :across (para:results report) + :if (and (typep result 'para:test-result) + (not (gethash result *processed-results*))) + :collect (make-junit-node result))) + s :indent t))) + (if (next-method-p) + (call-next-method) + report))