Commit 7f27d961 authored by Elias Pipping's avatar Elias Pipping

Tests: Cover %run-program

parent cd83552e
#!/bin/sh
if [ $# -gt 3 ]; then
exit 1
fi
if [ $# -ge 2 ]; then
echo $2
fi
if [ $# -ge 3 ]; then
echo $3 >&2
fi
exit ${1:-0}
#!/bin/sh
kill $$
#!/bin/sh
if [ $# -gt 2 ]; then
exit 1
fi
sleep ${2:-0}
exit ${1:-0}
(unless (os-unix-p)
(leave-test "This test can only be run on UNIX" 0))
#+abcl
(unless (version-satisfies
(second (split-string (implementation-identifier) :separator '(#\-)))
"1.4")
(leave-test
"This test is not meant to be run on versions of ABCL that predate 1.4" 0))
#+clasp
(leave-test "Clasp does not have a run-program function" 0)
#+cmucl
(let* ((v (first (uiop:split-string (lisp-implementation-version))))
(v-main (subseq v 0 2))
(v-sub (subseq v 2 3)))
(when (and (= 3 (length v)) ; cannot use length=n-p
(every #'digit-char-p v-main)
(every #'alpha-char-p v-sub))
(unless (or (version-satisfies v-main "22")
(and (version-satisfies v-main "21")
(not (string-equal v-sub "a"))))
(leave-test
"This test is not meant to be run on versions of CMU CL that predate 21B" 0))))
#+ecl
(unless (version-satisfies
(lisp-implementation-version)
"16.1.2")
(leave-test
"This test is not meant to be run on versions of ECL that predate 16.1.2" 0))
#+mkcl
(unless (version-satisfies (lisp-implementation-version) "1.1.10")
(leave-test
"This test is not meant to be run on versions of MKCL that predate 1.1.10" 0))
#-(or abcl allegro clasp clisp clozure cmucl ecl lispworks mkcl sbcl)
(leave-test "This test has never been run on your lisp and would probably fail" 0)
;;; Helpers
(defvar *input-file*
(subpathname *build-directory*
(strcat (implementation-identifier) "-" "input")))
(defvar *output-file*
(subpathname *build-directory*
(strcat (implementation-identifier) "-" "output")))
(defvar *error-output-file*
(subpathname *build-directory*
(strcat (implementation-identifier) "-" "error-output")))
;;; Test setup and execution
(defvar *suite-number* -1)
(defvar *test-number*)
(defvar *suites* nil)
(defvar *suites-reversed* t)
(defvar *letters* "abcdefghijklmnopqrstuvwxyz")
(defvar *number-of-failed-tests* 0)
(defvar *number-of-skipped-tests* 0)
(defvar *number-of-unsupported-tests* 0)
(defvar *number-of-unimplemented-tests* 0)
(defun new-test-suite (label)
(incf *suite-number*)
(setf *test-number* -1)
(push (list (format nil "~a ~a" *suite-number* label)) *suites*))
(defun push-test (test)
(push test (first *suites*)))
(defun run-tests ()
(when *suites-reversed*
(setf *suites* (reverse (mapcar #'reverse *suites*)))
(setf *suites-reversed* nil)
(dolist (suite *suites*)
(progn
(format t "~a~%" (first suite))
(dolist (test (cdr suite))
(funcall test)
(dolist (file (list *input-file* *output-file* *error-output-file*))
(delete-file-if-exists file)))))))
;; Defines a test that is automatically numbered. Within its body, the
;; following variables are available:
;; - output-string, error-string
;; - suite-number, test-number, test-letter
;; The description string str should not contain more than 57 characters
(defmacro define-test (str &body body)
`(progn
(incf *test-number*)
(push-test
(let ((suite-number *suite-number*)
(test-number *test-number*)
error-status
error-description)
#'(lambda ()
(let* ((test-letter (aref *letters* test-number))
(output-string (format nil "output~a~a"
suite-number test-number))
(error-string (format nil "error~a~a"
suite-number test-number)))
(declare (ignorable output-string error-string))
(format t " ~a ~a~%" test-letter ,str)
(block test-case
(handler-bind ((parameter-error
#'(lambda (c)
(declare (ignore c))
(incf *number-of-unsupported-tests*)
(setf error-status 'unsupported)
(return-from test-case)))
(not-implemented-error
#'(lambda (c)
(declare (ignore c))
(incf *number-of-unimplemented-tests*)
(setf error-status 'not-implemented)
(return-from test-case)))
(test-skipped
#'(lambda (c)
(incf *number-of-skipped-tests*)
(setf error-status 'skipped)
(setf error-description (format nil "~a" c))
(return-from test-case)))
(test-failure
#'(lambda (c)
(declare (ignore c))
(incf *number-of-failed-tests*)
(setf error-status 'failed)
(return-from test-case)))
(error
#'(lambda (c)
(incf *number-of-failed-tests*)
(setf error-status 'general)
(setf error-description (format nil "~a" c))
(return-from test-case))))
,@body))
(case error-status
(failed (incf *number-of-failed-tests*))
(unsupported (report-result "" "NOT SUPPORTED"))
(not-implemented (report-result "" "NOT IMPLEMENTED"))
(skipped (report-result "" "SKIPPED")
(format t " Skipped for the following reason: ~a~%"
error-description))
(general (report-result "" "ERROR")
(format t " The following error was encountered: ~a~%"
(string-trim (list #\Space #\ #\Newline)
error-description))))))))))
(define-condition test-skipped (error)
((reason :initarg :reason))
(:report (lambda (condition stream)
(format stream "~a" (slot-value condition 'reason)))))
(defun skip-test (reason)
(error 'test-skipped :reason reason))
(define-condition test-failure (error)
())
;;; Testing utilities
(defun file-contains-exactly (filename expected-content)
(let ((actual-content (read-file-string filename)))
(string= actual-content expected-content)))
(defun report-result (description outcome)
(format t " ~57,1,0,'.a ~a~%" description outcome))
(defun handle-result (description passed-or-not)
(unless passed-or-not
(report-result description "FAIL")
(error 'test-failure)))
(defun check-output (str)
(handle-result "output as expected?"
(file-contains-exactly *output-file* str)))
(defun check-error-output (str)
(handle-result "error-output as expected?"
(file-contains-exactly *error-output-file* str)))
(defun check-strings (str1 str2)
(handle-result "received what we sent?"
(string= str1 str2)))
(defun create-file-from-string (name string)
(with-open-file (output name :direction :output :if-exists :supersede)
(format output string)))
;; Wrapper that keeps us from special-casing CLISP since it
;; always requires :error-output :interactive to be set.
(defun %run-program (command &rest named-pairs
&key (error-output nil error-output-set)
&allow-other-keys)
(declare (ignore error-output #-clisp error-output-set))
(let ((args (append (list command)
named-pairs
#+clisp (unless error-output-set
(list :error-output :interactive)))))
(apply #'uiop/run-program::%run-program args)))
;;; The actual tests
(new-test-suite "%run-program")
(define-test
":input/:output/:error-output nil (default)"
(%run-program (format nil "./exiter.sh 0 ~a" output-string)
:wait nil :input nil :output nil))
(define-test
":error-output :interactive"
(%run-program (format nil "./exiter.sh 0 ~a" output-string)
:wait t :error-output :interactive))
(define-test
":error-output :output"
(%run-program (format nil "./exiter.sh 0 ~a" output-string)
:wait t :error-output :output))
(define-test
":output <file> (file e.)"
(progn
(create-file-from-string *output-file* "")
(%run-program (format nil "./exiter.sh 0 ~a" output-string)
:wait t :output *output-file*)
(check-output (format nil "~a~%" output-string))))
(define-test
":output <file> :error-output <file> (files e.)"
(progn
(create-file-from-string *output-file* "")
(create-file-from-string *error-output-file* "")
(%run-program (format nil "./exiter.sh 0 ~a ~a"
output-string error-string)
:wait t :output *output-file*
:error-output *error-output-file*)
(check-output (format nil "~a~%" output-string))
(check-error-output (format nil "~a~%" error-string))))
(define-test
":input <file> (file m.)"
(progn
(delete-file-if-exists *input-file*)
(%run-program "cat" :wait t :input *input-file*
:if-input-does-not-exist :create)))
(define-test
":input <file> (file e.)"
(progn
(let ((in-string (format nil "A line.~%And another.~%")))
(create-file-from-string *input-file* in-string))
(%run-program "cat" :wait t :input *input-file*
:if-input-does-not-exist :create)))
(define-test
":input <file> (as pathname; file e.)"
(progn
(let ((in-string (format nil "A line.~%And another.~%")))
(create-file-from-string *input-file* in-string))
(%run-program "cat" :wait t :input (truename *input-file*)
:if-input-does-not-exist :create)))
(define-test
":input <file> :output <file> (files e.)"
(progn
(let ((in-string (format nil "A line.~%And another.~%")))
(create-file-from-string *input-file* in-string)
(create-file-from-string *output-file* "")
(%run-program "cat" :wait t :input *input-file* :output *output-file*)
(check-output in-string))))
(define-test
":input <file> :output <file> (files e./m.)"
(progn
(let ((in-string (format nil "A line.~%And another.~%")))
(create-file-from-string *input-file* in-string)
(delete-file-if-exists *output-file*)
(%run-program "cat" :wait t :input *input-file*
:output *output-file*)
(check-output in-string))))
(define-test
":input <file> :output <file> (files e.), :i-o-e :append"
(progn
(let ((in-string1 (format nil "A line.~%"))
(in-string2 (format nil "And another.~%")))
(delete-file-if-exists *output-file*)
(create-file-from-string *input-file* in-string1)
(%run-program "cat" :wait t :input *input-file*
:output *output-file*)
(create-file-from-string *input-file* in-string2)
(%run-program "cat" :wait t :input *input-file*
:output *output-file*
:if-output-exists :append)
(check-output (concatenate 'string in-string1 in-string2)))))
(define-test
":output <fstream> :error-output <fstream>"
(progn
(with-open-file (output *output-file* :direction :output
:if-exists :supersede
#+clozure :sharing #+clozure :lock)
(with-open-file (error-output *error-output-file* :direction :output
:if-exists :supersede
#+clozure :sharing #+clozure :lock)
(%run-program (format nil "./exiter.sh 0 ~a ~a"
output-string error-string)
:wait t :output output :error-output error-output)))
(check-output (format nil "~a~%" output-string))
(check-error-output (format nil "~a~%" error-string))))
(define-test
":input <file> :output <sstream>"
(let ((in-string (format nil "A line.~%And another.~%")))
(create-file-from-string *input-file* in-string)
(with-output-to-string (out-stream)
(%run-program "cat" :wait t :input *input-file* :output out-stream)
(check-strings in-string (get-output-stream-string out-stream)))))
(define-test
":input <sstream> :output <sstream>"
(let ((in-string (format nil "A line.~%And another.~%")))
(with-output-to-string (out-stream nil)
(with-input-from-string (in-stream in-string)
(%run-program "cat" :wait t :input in-stream :output out-stream))
(check-strings in-string (get-output-stream-string out-stream)))))
(define-test
":input <file> :output :stream"
(let ((in-string (format nil "A line.~%And another.~%")))
(with-open-file (input *input-file* :direction :output
:if-exists :supersede)
(format input in-string))
(let* ((process (%run-program "cat" :wait t :input *input-file*
:output :stream))
(output (process-info-output process))
(out-string (make-string (length in-string))))
(read-sequence out-string output)
(check-strings in-string out-string)
(close-streams process))))
(define-test
":input <file> :output :stream :wait nil"
(let ((in-string (format nil "A line.~%And another.~%")))
(with-open-file (input *input-file* :direction :output
:if-exists :supersede)
(format input in-string))
(let* ((process (%run-program "cat" :wait nil :input *input-file*
:output :stream))
(output (process-info-output process))
(out-string (make-string (length in-string))))
(wait-process process)
(read-sequence out-string output)
(check-strings in-string out-string)
(close-streams process))))
(defvar *dynamic-input*)
(define-test
":input <fstream-synonym> :output <file>"
(let ((in-string (format nil "A line.~%And another.~%")))
(with-open-file (input *input-file* :direction :output
:if-exists :supersede)
(format input in-string))
(create-file-from-string *output-file* "")
(with-open-file (input *input-file* :direction :input
:if-does-not-exist :error)
(let* ((*dynamic-input* input)
(input-synonym (make-synonym-stream '*dynamic-input*)))
(%run-program "cat" :wait t
:input input-synonym
:output *output-file*))
(check-output in-string))))
(define-test
":input <sstream-synonym> :output <file>"
(progn
(create-file-from-string *output-file* "")
(let ((in-string (format nil "A line.~%And another.~%")))
(with-input-from-string (input in-string)
(let* ((*dynamic-input* input)
(input-synonym (make-synonym-stream '*dynamic-input*)))
(%run-program "cat" :wait t
:input input-synonym
:output *output-file*)))
(check-output in-string))))
(define-test
":directory"
(let* ((in-string (format nil "A line.~%And another.~%"))
(temporary-directory
(subpathname *build-directory*
(format nil "test-run-program-unix/~a"
(implementation-identifier))
:type :directory))
(relative-filename "input")
(temporary-file (subpathname temporary-directory relative-filename)))
(ensure-directories-exist temporary-directory)
(create-file-from-string temporary-file in-string)
(delete-file-if-exists *output-file*)
(%run-program (format nil "cat ~a" relative-filename)
:wait t :output *output-file* :directory temporary-directory)
(check-output in-string)))
(new-test-suite "%process-info-pid")
(define-test
"basic functionality"
(let* ((process-info (%run-program "./sleeper.sh 12 1" :wait nil))
(pid (uiop/run-program::%process-info-pid process-info)))
(handle-result "obtainable and plausible?"
(and (numberp pid) (plusp pid)))
(wait-process process-info)))
(fresh-line)
(run-tests)
(write-line "")
(when (plusp *number-of-failed-tests*)
(format t "~2@a sub-tests failed.~%" *number-of-failed-tests*))
(when (plusp *number-of-skipped-tests*)
(format t "~2@a sub-tests skipped because of known errors.~%"
*number-of-skipped-tests*))
(when (plusp *number-of-unsupported-tests*)
(format t "~2@a sub-tests could not be run on this platform (not supported).~%"
*number-of-unsupported-tests*))
(when (plusp *number-of-unimplemented-tests*)
(format t "~2@a sub-tests could not be run on this platform (not implemented).~%"
*number-of-unimplemented-tests*))
(when (plusp *number-of-failed-tests*)
(format *error-output*
"Exiting with non-zero code because of unexpected test failures.~%")
(exit-lisp 1))
(exit-lisp 0)
;; Local Variables:
;; mode:common-lisp
;; End:
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment