File: run-tests.lisp

package info (click to toggle)
cl-xmls 3.0.2-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 720 kB
  • sloc: xml: 7,639; lisp: 1,084; perl: 101; makefile: 39
file content (111 lines) | stat: -rw-r--r-- 4,351 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
(defpackage xmls-test-runner
  (:use :common-lisp))

(in-package :xmls-test-runner)

(require :asdf)
(format t "ASDF version is ~a~%" (asdf:asdf-version))
(defparameter *quicklisp-p* (not (zerop (parse-integer (uiop:getenv "QUICKLISP")))) )
(when *quicklisp-p*
  (load (merge-pathnames "quicklisp/setup.lisp" 
                           (user-homedir-pathname))))
(defmacro quit-on-error (&body body)
  (let ((code 1))
   (when (numberp (first body))
     (setf code (pop body)))
    `(call-quitting-on-error (lambda () ,@body) ,code)))

(defun call-quitting-on-error (thunk &optional (code 1))
  "Unless the environment variable DEBUG_ASDF_TEST
is bound, write a message and exit on an error.  If
*asdf-test-debug* is true, enter the debugger."
  (flet ((quit (c desc)
           (uiop:safe-format! *error-output* "~&Encountered ~a during test.~%~a~%" desc c)
           (cond
            ;; decline to handle the error.
            ((ignore-errors (funcall (find-symbol "GETENV" :asdf) "DEBUG_ASDF_TEST"))
             (format t "~&Interactive mode (DEBUG_ASDF_TEST) -- Invoke debugger.~%")
             (invoke-debugger c))
            (t
             (finish-output *standard-output*)
             (finish-output *trace-output*)
             (uiop:safe-format! *error-output* "~&ABORTING:~% ~S~%" c)
             (uiop:print-condition-backtrace c)
             (uiop:safe-format! *error-output* "~&ABORTING:~% ~S~%" c)
             (uiop:safe-format! *error-output* "~&Script failed~%")
             (finish-output *error-output*)
             (uiop:quit code t)))))
    (handler-bind
        ((error (lambda (c)
                  (quit c  "ERROR")))
         (storage-condition
          (lambda (c) (quit c "STORAGE-CONDITION")))
         (serious-condition (lambda (c)
                              (quit c "Other SERIOUS-CONDIITON"))))
      (funcall thunk)
      (format t "~&Script succeeded~%")
      t)))


;; for this to work, we must ensure that ASDF gets an OK configuration
;; on startup.
(setf asdf:*compile-file-failure-behaviour* :error)
(quit-on-error
 (macrolet ((load-system (s)
                         (if *quicklisp-p* `(uiop:symbol-call '#:ql '#:quickload ,s)`(asdf:load-system ,s))))
   (load-system :flexi-streams)
   (load-system :fiveam)
   (load-system "cl-ppcre")))               ; need to do this here because it doesn't build without warnings.
(setf asdf:*compile-file-warnings-behaviour* :error)
(defvar *build-warning* nil)
(defvar *build-error* nil)
(catch 'build-fail
 (handler-bind ((warning #'(lambda (x)
                             ;; this is necessary because on SBCL
                             ;; there's an EXTERNAL handler for some
                             ;; uninteresting warnings.
                             (signal x)
                             (push x *build-warning*)
                             (throw 'build-fail :fail)))
                (error #'(lambda (x)
                           (push x *build-error*)
                           (throw 'build-fail :warn))))
   (asdf:load-system "xmls" :force t)))
(cond (*build-error*
       (uiop:die 1 "XMLS build failed with error(s):~%~{~a~%~}"
               *build-error*))
      (*build-warning*
       (uiop:die 1 "XMLS build failed with warning(s):~%~{~a~%~}"
               *build-warning*)))

(catch 'build-fail
 (handler-bind ((warning #'(lambda (x)
                             ;; this is necessary because on SBCL
                             ;; there's an EXTERNAL handler for some
                             ;; uninteresting warnings.
                             (signal x)
                             (push x *build-warning*)
                             (throw 'build-fail :fail)))
                (error #'(lambda (x)
                           (push x *build-error*)
                           (throw 'build-fail :warn))))
   (asdf:load-system "xmls/octets" :force t)))
(cond (*build-error*
       (uiop:die 2 "XMLS/OCTETS build failed with error(s):~%~{~a~%~}"
               *build-error*))
      (*build-warning*
       (uiop:die 2 "XMLS/OCTETS build failed with warning(s):~%~{~a~%~}"
               *build-warning*)))


(quit-on-error
  3
 (format t "~&;;; Testing XMLS.~%")
 (asdf:test-system "xmls"))

(quit-on-error
  4
 (format t "~&;;; Testing XMLS/OCTETS.~%")
 (asdf:test-system "xmls/octets"))

(uiop:quit 0)