external/lift.darcs/dev/config.lisp

   1 (in-package #:lift)
   2
   3 (defvar *current-configuration-stream* nil)
   4
   5 (defvar *current-asdf-system-name* nil)
   6
   7 (eval-when (:load-toplevel :execute)
   8   (when (find-package :asdf)
   9     (defmethod asdf:perform :around ((operation asdf:test-op) (c asdf:system))
  10       (let ((*current-asdf-system-name* (asdf:component-name c)))
  11         (call-next-method)))))
  12
  13 (defun find-generic-test-configuration ()
  14   (let ((srp (and *current-asdf-system-name*
  15                   (find-package :asdf)
  16                   (intern (symbol-name 'system-relative-pathname) :asdf))))
  17     (cond (srp
  18            (or (probe-file (funcall srp
  19                                     *current-asdf-system-name*
  20                                     "lift-local.config"))
  21                (probe-file (funcall srp
  22                                     *current-asdf-system-name*
  23                                     "lift-standard.config"))
  24                (error "Unable to find lift-local.config or lift-standard.config relative to the current system (~s)" *current-asdf-system-name*)))
  25           (t
  26            (error "Unable to use :generic configuration option either because ASDF is not loaded or because asdf:system-relative-pathname is not bound (maybe try updating?) or because the current system cannot be determined.")))))
  27
  28 (defun run-tests-from-file (path)
  29   (let ((real-path (cond ((eq path :generic)
  30                           (setf path (find-generic-test-configuration)))
  31                          (t
  32                           (probe-file path)))))
  33     (unless real-path
  34       (error "Unable to find configuration file ~s" path))
  35     (setf *test-result*
  36           (let* ((*package* *package*)
  37                  (*read-eval* nil)
  38                  (result (make-test-result path :multiple))
  39                  (*lift-dribble-pathname* nil)
  40                  (*lift-debug-output* *debug-io*)
  41                  (*lift-standard-output* *standard-output*)
  42                  (*test-break-on-errors?* nil)
  43                  (*test-do-children?* t)
  44                  (*lift-equality-test* 'equal)
  45                  (*test-print-length* :follow-print)
  46                  (*test-print-level* :follow-print)
  47                  (*lift-if-dribble-exists* :append)
  48                  (*test-result* result))
  49             (%run-tests-from-file path)))))
  50
  51 (defun %run-tests-from-file (path)
  52   (with-open-file (*current-configuration-stream* path
  53                       :direction :input
  54                       :if-does-not-exist :error)
  55     (let ((form nil))
  56       (loop while (not (eq (setf form (read *current-configuration-stream*
  57                                             nil :eof nil)) :eof))
  58          collect
  59          (handler-bind
  60              ((error (lambda (c) (format
  61                                   *error-output*
  62                                   "Error while running ~a from ~a: ~a"
  63                                   form path c)
  64                              (invoke-debugger c))))
  65            (destructuring-bind
  66                  (name &rest args)
  67                form
  68              (assert (typep name 'symbol) nil
  69                      "Each command must be a symbol and ~s is not." name)
  70              (setf args (massage-arguments args))
  71              (cond
  72                ;; check for preferences first (i.e., keywords)
  73                ((eq (symbol-package name)
  74                     (symbol-package :keyword))
  75                 ;; must be a preference
  76                 (handle-config-preference name args))
  77                ((subtypep (find-testsuite name)
  78                           'lift:test-mixin)
  79                 (apply #'run-tests :suite name
  80                        :result *test-result* args))
  81                (t
  82                 (error "Don't understand '~s' while reading from ~s"
  83                        form path))))))))
  84   (values *test-result*))
  85
  86 (defun massage-arguments (args)
  87   (loop for arg in args collect
  88        (cond ((and (symbolp arg)
  89                    (string= (symbol-name arg) (symbol-name '*standard-output*)))
  90               *standard-output*)
  91              (t arg))))
  92
  93 (defmethod handle-config-preference ((name t) args)
  94   (error "Unknown preference ~s (with arguments ~s)"
  95          name args))
  96
  97 (defmethod handle-config-preference ((name (eql :include)) args)
  98   (%run-tests-from-file (merge-pathnames (first args)
  99                                          *current-configuration-stream*)))
 100
 101 (defmethod handle-config-preference ((name (eql :dribble)) args)
 102   (setf *lift-dribble-pathname* (first args)))
 103
 104 (defmethod handle-config-preference ((name (eql :debug-output)) args)
 105   (setf *lift-debug-output* (first args)))
 106
 107 (defmethod handle-config-preference ((name (eql :standard-output)) args)
 108   (setf *lift-standard-output* (first args)))
 109
 110 (defmethod handle-config-preference ((name (eql :break-on-errors?)) args)
 111   (setf *test-break-on-errors?* (first args)))
 112
 113 (defmethod handle-config-preference ((name (eql :do-children?)) args)
 114   (setf *test-do-children?* (first args)))
 115
 116 (defmethod handle-config-preference ((name (eql :equality-test)) args)
 117   (setf *lift-equality-test* (first args)))
 118
 119 (defmethod handle-config-preference ((name (eql :print-length)) args)
 120   (setf *test-print-length* (first args)))
 121
 122 (defmethod handle-config-preference ((name (eql :print-level)) args)
 123   (setf *test-print-level* (first args)))
 124
 125 (defmethod handle-config-preference ((name (eql :print-suite-names)) args)
 126   (setf *test-print-testsuite-names* (first args)))
 127
 128 (defmethod handle-config-preference ((name (eql :print-test-case-names)) args)
 129   (setf *test-print-test-case-names* (first args)))
 130
 131 (defmethod handle-config-preference ((name (eql :if-dribble-exists))
 132                                      args)
 133   (setf *lift-if-dribble-exists* (first args)))
 134
 135 (defmethod handle-config-preference ((name (eql :report-property))
 136                                      args)
 137   (setf (test-result-property *test-result* (first args)) (second args)))
 138
 139 (defmethod handle-config-preference ((name (eql :profiling-threshold))
 140                                      args)
 141   (setf *profiling-threshold* (first args)))
 142
 143 (defmethod handle-config-preference ((name (eql :build-report))
 144                                      args)
 145   (declare (ignore args))
 146   (let* ((dest (or (test-result-property *test-result* :full-pathname)
 147                    (asdf:system-relative-pathname
 148                     (or (test-result-property *test-result* :relative-to)
 149                         'lift)
 150                     (or (test-result-property *test-result* :name)
 151                         "report.html"))))
 152          (format (or (test-result-property *test-result* :format)
 153                      :html))
 154          (unique-name (test-result-property *test-result* :unique-name)))
 155     (when (and unique-name (not (streamp dest)))
 156       (setf dest (unique-filename dest)))
 157     (with-standard-io-syntax
 158       (let ((*print-readably* nil))
 159         (handler-case
 160             (cond
 161               ((or (streamp dest) (writable-directory-p dest))
 162                (format *debug-io* "~&Sending report (format ~s) to ~a"
 163                        format dest)
 164                (test-result-report
 165                 *test-result*
 166                 dest
 167                 format))
 168               (t
 169                (format *debug-io* "~&Unable to write report (format ~s) to ~a"
 170                        format dest)))
 171           (error (c)
 172             (format *debug-io*
 173                     "Error ~a while generating report (format ~s) to ~a"
 174                     c format dest)))))))
 175