test-environment.lisp 9.57 KB
Newer Older
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
(in-package :asdf-tools)

;;; Testing

(defparameter *test-lisps* :default
  "The list of lisp implementations to use for tests")

(defparameter *upgrade-test-lisps* :default
  "The list of lisp implementations to use for upgrade tests")

(defparameter *upgrade-test-tags* :default)

(defparameter *test-systems* nil)

(defparameter *test-scripts* :default)

(defparameter *environment-variable-table* nil)

(defparameter *environment-variable-specs*
  '((*test-lisps* ensure-list-of-keywords :default
     "ASDF_TEST_LISPS" "l")
    (*upgrade-test-lisps* ensure-list-of-keywords :default
     "ASDF_UPGRADE_TEST_LISPS" "L")
    (*test-systems* ensure-list-of-keywords ()
     "ASDF_TEST_SYSTEMS" "s")
    (*test-scripts* ensure-list-of-strings :default
     "ASDF_TESTS" "t")
    (*upgrade-test-tags* ensure-list-of-strings :default
     "ASDF_UPGRADE_TEST_TAGS" "u")
    (*upgrade-test-methods* ensure-list-of-test-methods :default
     "ASDF_UPGRADE_TEST_METHODS" "U")
    (*new-version* string :default
     "=NEW_ASDF_VERSION" "v")))

(defun ensure-list-of-strings (x)
  (remove nil
          (etypecase x
            (string (uiop:split-string x :separator " "))
            (list x))))

(defun ensure-keyword (x)
  (etypecase x
    ((or null keyword) x)
44
    ((or string symbol) (intern (standard-case-symbol-name x) :keyword))))
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62

(defun ensure-list-of-keywords (x)
  (mapcar 'ensure-keyword (ensure-list-of-strings x)))

(defun ensure-test-method (x)
  (safe-read-from-string (strcat "(" (substitute #\space #\: x) ")") :package :keyword)) ; UGLY!

(defun ensure-list-of-test-methods (x)
  (mapcar 'ensure-test-method (ensure-list-of-strings x)))

(defun initialize-environment ()
  (let ((h (make-hash-table :test 'equal)))
    (setf *environment-variable-table* h)
    (loop :for (variable transformer defaults envvar short) :in *environment-variable-specs*
          :for x = (list variable transformer)
          :do (setf (symbol-value variable)
                    (if-let (x (getenvp envvar))
                      (funcall transformer x)
63
                      (eval defaults)))
64 65 66
              (setf (gethash envvar h) x)
              (setf (gethash short h) x))))

67 68
(defun display-environment ()
  (format t "Environment for ASDF tools:~%")
69 70 71
  (let ((*package* (find-package :asdf-tools)))
    (loop :for variable-name :in (mapcar 'first *environment-variable-specs*)
          :do (format t "~T~S = ~S~%"
72
                      variable-name (symbol-value variable-name))))
73
  (success))
74

75 76
(defun test-definition (def)
  (block ()
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
77 78 79 80 81 82 83 84 85
    (match def
      ((ppcre "^([^=]+)=(.*)$" var val)
       (if-let (x (gethash var *environment-variable-table*))
         (match x
           ((list* sym transformer _)
            (unless (emptyp val)
              (setf (symbol-value sym) (funcall transformer val)))
            (return t)))
         (error "Unknown variable ~A" var))))
86
    nil))
87 88 89 90

(defun show-environment ()
  (loop :for (v) :in *environment-variable-specs* :do
    (format t "~A = ~S~%" v (symbol-value v)))
91
  (success))
92

93 94 95 96 97 98 99
(defun env (&rest env)
  (loop :for (first . rest) :on env
        :unless (test-definition first)
          :return (if-let (c (find-command first))
                    (apply c rest)
                    (progn (format t "Command ~A not found~%" first) nil))
        :finally (progn (format t "No command provided~%") (return))))
100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun decl-or-docstring-p (form)
    (or (stringp form)
        (and (consp form) (eq 'declare (car form)))))

  (defun decl-and-body (decl-and-body)
    (let ((p (position-if-not 'decl-or-docstring-p decl-and-body)))
      (values (subseq decl-and-body 0 p)
              (nthcdr p decl-and-body)))))

(defmacro deftestcmd (name args &rest decl-and-body)
  (loop :with argmap =
        '((lisp ((lisp *test-lisps*))
           (setf lisp (get-lisp lisp)))
          (lisps ((lisps *test-lisps*))
           (setf lisps (get-lisps lisps)))
117 118
          (upgrade-lisps ((upgrade-lisps *upgrade-test-lisps*))
           (setf upgrade-lisps (get-upgrade-lisps upgrade-lisps)))
119 120 121 122 123 124
          (systems ((systems *test-systems*)))
          (test-scripts ((test-scripts *test-scripts*))
           (setf test-scripts (get-test-scripts test-scripts)))
          (upgrade-tags ((upgrade-tags *upgrade-test-tags*))
           (setf upgrade-tags (get-upgrade-tags upgrade-tags)))
          (upgrade-methods ((upgrade-methods *upgrade-test-methods*))
125 126 127
           (setf upgrade-methods (get-upgrade-methods upgrade-methods)))
          (new-version (new-version)
           (setf new-version (or new-version (next-version (version-from-file))))))
128 129 130 131 132 133 134 135 136
        :for arg :in args
        :for (found larg init) = (assoc arg argmap)
        :append (if found larg (list arg)) :into largs
        :append (when found (list init)) :into inits
        :finally
           (multiple-value-bind (decl body) (decl-and-body decl-and-body)
             (return
               `(defun ,name (&optional ,@largs)
                  ,@decl
137
                  (with-failure-context (:name ,(command-name name))
138 139 140
                    ,@inits
                    ,@body
                    (success))))))) ;; use return-from ,name to return a value.
141 142

(defmacro defalias (name real)
143 144 145
  `(defun ,name (&rest args)
     ,(format nil "alias for command ~A" (command-name real t))
     (apply ',real args)))
146 147 148

(deftestcmd interactive-command (lisp)
  (let* ((command (lisp-invocation-arglist :implementation-type lisp :debugger t)))
149
    (return-from interactive-command (cons "rlwrap" command))))
150 151 152

(defparameter *default-test-lisps*
  '(:ccl :clisp :sbcl :ecl :ecl_bytecodes :cmucl :abcl :scl :allegro
153
    :lispworks :allegromodern :clasp :gcl :xcl :mkcl)
154 155 156 157 158 159 160 161 162 163 164 165
  ;; NOT SUPPORTED BY OUR AUTOMATED TESTS:
  ;; :cormancl :genera :lispworks-personal-edition :mcl
  ;; Also, grep for #+/#- features in the test/ directory
  ;; to see plenty of disabled tests on some platforms
  "Default Lisp implementations for tests")

(defun get-lisps (&optional (lisps *test-lisps*))
  (if (eq lisps :default) *default-test-lisps* (ensure-list-of-keywords lisps)))

(defun get-lisp (&optional (lisp *test-lisps*))
  (if (and (keywordp lisp) (not (eq lisp :default))) lisp (first (get-lisps lisp))))

166 167 168
(defun get-upgrade-lisps (&optional (x *upgrade-test-lisps*))
  (if (eq x :default) (get-lisps) x))

169 170 171 172 173 174 175 176 177 178 179 180
(defun date-string (&optional (date (get-universal-time)))
  (multiple-value-bind (second minute hour date month year weekday daylight-savings-p timezone)
      (decode-universal-time date)
    (declare (ignore second minute hour weekday daylight-savings-p timezone))
    (format nil "~4,'0D-~2,'0D-~2,'0D" year month date)))

(deftestcmd newlogfile ((kind "log") lisp)
  (let ((log (pn (format nil "build/results/~(~A-~A~).text" lisp kind))))
    (ensure-directories-exist log)
    (if-let (date (safe-file-write-date log))
      (rename-file-overwriting-target
       log (add-pathname-suffix log (strcat "-" (date-string date)))))
181
    (with-output-file (s log) s) ;; create the file
182
    ;;(format t "Logging results to ~A" log)
183
    (return-from newlogfile log)))
184 185 186 187 188 189 190 191 192

(defun log! (log fmt &rest args)
  (let ((msg (apply 'format nil fmt args)))
    (format t "~&~A~&" msg)
    (when log
      (with-output-file (s log :if-exists :append :if-does-not-exist :create)
        ;; re-open every time because we're interleaved with inferior process writing to the log,
        ;; and on e.g. Windows there might be a locking conflict if we keep it open.
        (format s "~&~A~&" msg))))
193
  (success))
194 195 196 197 198 199 200

;; TODO: When composing a form to evaluate in the test lisp implementation,
;; our shell script went through great lengths to avoid a double-quote #\" in the command line,
;; the quoting of which many Windows implementations get wrong.
;; While we're at it, we also avoid spaces and backslashes.
;; We haven't tested our new Lisp implementation of the test infrastructure on Windows, though.

201 202
(defun run* (cmd &rest keys)
  (let* ((string (strcat "`" (print-process-spec cmd) "`")))
203
    (with-failure-context (:name string)
204 205 206 207
      (apply 'run cmd
             :on-error (lambda (c) (fail! "process failed with code ~A" (subprocess-error-code c)))
             keys))))

208 209
(defun run-test-lisp (activity forms &key (output t) log lisp debugger)
  ;; Activity is of the form "compiling ASDF", "running this test", etc.
210
  (format t "~&Now ~A...~@[ (log in ~A)~]~%" activity log)
211 212 213 214 215 216 217
  (let* ((eval (compose-eval-string forms))
         (command (lisp-invocation-arglist :implementation-type (get-lisp lisp)
                                           :eval eval :debugger debugger))
         (interactive (if (eq output :interactive) :interactive nil))
         (output (if (eq output t) *standard-output* output))
         (output (if (eq output *stdout*) :interactive output)))
    (log! log "~A" (print-process-spec command nil))
218 219 220 221 222 223 224 225 226 227
    (multiple-value-bind (out err code)
        (run `((>& 2 1) ,@(when interactive '(rlwrap)) ,@command
               ,@(when log `((>> ,log)))) ;; unhappily, | tee -a log eats error codes :-(
             :input interactive :output output :error-output (or interactive :output) :on-error nil)
      (declare (ignore out err))
      (let ((okp (eql code 0)))
        (unless interactive
          (log! log (if okp
                        "SUCCEEDED at ~A."
                        "FAILED at ~A.
228 229 230 231 232
You can retry ~A with:
    ~A
or more interactively, start with:
    ~A~%(rlwrap is optional; don't use it when in emacs; skip if not installed.)
then copy/paste:
233 234 235 236 237
~@<    ~@;~A~@:>~&")
              activity activity
              (print-process-spec command nil)
              (print-process-spec (interactive-command) nil)
              (compose-copy-paste-string forms)))
238
        (success-if okp "failed at ~A" activity)))))