test-environment.lisp

(in-package :asdf-tools)

;;; Testing
#|
To configure the lisp implementations with which to run the tests,
you may export environment variables to override the defaults:
ASDF_TEST_LISPS and ASDF_UPGRADE_TEST_LISPS can each be a string of space-separated names
amongst the above implementation names.
You may also explicitly specify the same variables with the respective l= and u= arguments.
Individual test commands only use the first (preferred) provided implementation;
other test commands (named test-all-FOO) iterate over all implementations.

Similarly, you can configure which scripts to tests with ASDF_TEST_SCRIPTS or t=
and which systems to test loading with ASDF_TEST_SYSTEMS or s=
|#

(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)
    ((or string symbol) (intern (standard-case-symbol-name x) :keyword))))

(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)
                      (eval defaults)))
              (setf (gethash envvar h) x)
              (setf (gethash short h) x))))

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

(defun test-definition (def)
  (block ()
    (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))))
    nil))

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

(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))))

(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)))
          (upgrade-lisps ((upgrade-lisps *upgrade-test-lisps*))
           (setf upgrade-lisps (get-upgrade-lisps upgrade-lisps)))
          (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*))
           (setf upgrade-methods (get-upgrade-methods upgrade-methods)))
          (new-version (new-version)
           (setf new-version (or new-version (compute-next-version (version-from-file))))))
        :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 ,(and largs `(&optional ,@largs))
                  ,@decl
                  (with-failure-context (:name ,(command-name name))
                    ,@inits
                    ,@body
                    (success))))))) ;; use return-from ,name to return a value.

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

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

(defparameter *default-test-lisps*
  '(:ccl :clisp :sbcl :ecl :ecl_bytecodes :cmucl :abcl :scl :allegro
    :lispworks :allegromodern :clasp :gcl :xcl :mkcl)
  ;; 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))))

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

(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)))))
    (with-output-file (s log) s) ;; create the file
    ;;(format t "Logging results to ~A" log)
    (return-from newlogfile log)))

(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))))
  (success))

;; 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.

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

(defun run-test-lisp (activity forms &key (output t) log lisp debugger)
  ;; Activity is of the form "compiling ASDF", "running this test", etc.
  (format t "~&Now ~A...~@[ (log in ~A)~]~%" activity log)
  (let* ((eval (compose-non-special-string forms)) ;; at least avoiding ~% is necessary on Windows.
         (command (lisp-invocation-arglist :implementation-type (get-lisp lisp)
                                           :eval eval :debugger debugger :console t))
         (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))
    (multiple-value-bind (out err code)
        (run `(,@(when interactive '(rlwrap))
               ,@command
               ,@(when log `((>> ,log) (>& 2 1)))) ;; 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.
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:
~@<    ~@;~A~@:>~&~
 Note that to debug rather than merely reproduce, you may want to call~%~
 (asdf-test::debug-asdf) before last form to avoid quit-on-failure behavior~%")
              activity activity
              (print-process-spec command nil)
              (print-process-spec (interactive-command lisp) nil)
              (compose-copy-paste-string forms)))
        (success-if okp "failed at ~A" activity)))))