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 lift-relative-pathname (pathname &optional (errorp nil))
  14   "Merges pathname with either the path to the currently loading system
  15 \(if there is one\) or the *default-pathname-defaults*."
  16   (let* ((asdf-package (find-package :asdf))
  17          (srp-symbol (and asdf-package
  18                           (find-symbol (symbol-name 'system-relative-pathname)
  19                                        asdf-package)))
  20          (srp (and *current-asdf-system-name* srp-symbol)))
  21     (labels ((try-it (path)
  22                (let ((pathname (merge-pathnames pathname path)))
  23                  (if errorp (and pathname (probe-file pathname)) pathname))))
  24       (or (and srp (try-it (funcall srp *current-asdf-system-name* "")))
  25           (try-it *default-pathname-defaults*)
  26           (not errorp)
  27           (and (not asdf-package)
  28                (error "Unable to use :generic configuration option because ASDF is not loaded."))
  29           (and (not srp-symbol)
  30                (error "Unable to use :generic configuration option because asdf:system-relative-pathname is not function bound (maybe try updating ASDF?)"))
  31           (and (not *current-asdf-system-name*)
  32                (error "Unable to use :generic configuration option because because the current system cannot be determined. Are you using asdf:test-op?"))))))
  33
  34 (defun find-generic-test-configuration (&optional (errorp nil))
  35   (flet ((try-it (path)
  36            (and path (probe-file path))))
  37     (or (try-it (lift-relative-pathname "lift-local.config" errorp))
  38         (try-it (lift-relative-pathname "lift-standard.config" errorp))
  39         (and errorp
  40              (error "Unable to use :generic configuration file neither lift-local.config nor lift-standard.config can be found.")))))
  41
  42 (defun report-summary-pathname ()
  43   (unique-filename (generate-report-summary-pathname)))
  44
  45 (defmethod generate-report-summary-pathname ()
  46   (lift-relative-pathname "test-results/summary.sav"))
  47
  48 #+(or)
  49 (generate-report-summary-pathname)
  50
  51 (defun run-tests-from-file (path)
  52   (let ((real-path (cond ((eq path :generic)
  53                           (setf path
  54                                 (find-generic-test-configuration t)))
  55                          (t
  56                           (probe-file path)))))
  57     (unless real-path
  58       (error "Unable to find configuration file ~s" path))
  59     (setf *test-result*
  60           (let* ((*package* *package*)
  61                  (*read-eval* nil)
  62                  (result (make-test-result path :multiple))
  63                  (*lift-dribble-pathname* nil)
  64                  (*lift-debug-output* *debug-io*)
  65                  (*lift-standard-output* *standard-output*)
  66                  (*test-break-on-errors?* nil)
  67                  (*test-do-children?* t)
  68                  (*lift-equality-test* 'equal)
  69                  (*test-print-length* :follow-print)
  70                  (*test-print-level* :follow-print)
  71                  (*lift-if-dribble-exists* :append)
  72                  (*test-result* result))
  73             (%run-tests-from-file path)))))
  74
  75 (defun %run-tests-from-file (path)
  76   (with-open-file (*current-configuration-stream* path
  77                       :direction :input
  78                       :if-does-not-exist :error)
  79     (let ((form nil))
  80       (loop while (not (eq (setf form (read *current-configuration-stream*
  81                                             nil :eof nil)) :eof))
  82          collect
  83          (handler-bind
  84              ((error (lambda (c) (format
  85                                   *error-output*
  86                                   "Error while running ~a from ~a: ~a"
  87                                   form path c)
  88                              (print (get-backtrace c))
  89                              (invoke-debugger c))))
  90            (destructuring-bind
  91                  (name &rest args)
  92                form
  93              (assert (typep name 'symbol) nil
  94                      "Each command must be a symbol and ~s is not." name)
  95              (setf args (massage-arguments args))
  96              (cond
  97                ;; check for preferences first (i.e., keywords)
  98                ((eq (symbol-package name)
  99                     (symbol-package :keyword))
 100                 ;; must be a preference
 101                 (handle-config-preference name args))
 102                ((subtypep (find-testsuite name)
 103                           'lift:test-mixin)
 104                 (apply #'run-tests :suite name
 105                        :result *test-result* args))
 106                (t
 107                 (error "Don't understand '~s' while reading from ~s"
 108                        form path))))))))
 109   (values *test-result*))
 110
 111 (defun massage-arguments (args)
 112   (loop for arg in args collect
 113        (cond ((and (symbolp arg)
 114                    (string= (symbol-name arg) (symbol-name '*standard-output*)))
 115               *standard-output*)
 116              (t arg))))
 117
 118 (defmethod handle-config-preference ((name t) args)
 119   (error "Unknown preference ~s (with arguments ~s)"
 120          name args))
 121
 122 (defmethod handle-config-preference ((name (eql :include)) args)
 123   (%run-tests-from-file (merge-pathnames (first args)
 124                                          *current-configuration-stream*)))
 125
 126 (defmethod handle-config-preference ((name (eql :dribble)) args)
 127   (setf *lift-dribble-pathname* (first args)))
 128
 129 (defmethod handle-config-preference ((name (eql :debug-output)) args)
 130   (setf *lift-debug-output* (first args)))
 131
 132 (defmethod handle-config-preference ((name (eql :standard-output)) args)
 133   (setf *lift-standard-output* (first args)))
 134
 135 (defmethod handle-config-preference ((name (eql :break-on-errors?)) args)
 136   (setf *test-break-on-errors?* (first args)))
 137
 138 (defmethod handle-config-preference ((name (eql :do-children?)) args)
 139   (setf *test-do-children?* (first args)))
 140
 141 (defmethod handle-config-preference ((name (eql :equality-test)) args)
 142   (setf *lift-equality-test* (first args)))
 143
 144 (defmethod handle-config-preference ((name (eql :print-length)) args)
 145   (setf *test-print-length* (first args)))
 146
 147 (defmethod handle-config-preference ((name (eql :print-level)) args)
 148   (setf *test-print-level* (first args)))
 149
 150 (defmethod handle-config-preference ((name (eql :print-suite-names)) args)
 151   (setf *test-print-testsuite-names* (first args)))
 152
 153 (defmethod handle-config-preference ((name (eql :print-test-case-names)) args)
 154   (setf *test-print-test-case-names* (first args)))
 155
 156 (defmethod handle-config-preference ((name (eql :if-dribble-exists))
 157                                      args)
 158   (setf *lift-if-dribble-exists* (first args)))
 159
 160 (defmethod handle-config-preference ((name (eql :report-property))
 161                                      args)
 162   (setf (test-result-property *test-result* (first args)) (second args)))
 163
 164 (defmethod handle-config-preference ((name (eql :profiling-threshold))
 165                                      args)
 166   (setf *profiling-threshold* (first args)))
 167
 168 (defmethod handle-config-preference ((name (eql :count-calls-p))
 169                                      args)
 170   (setf *count-calls-p* (first args)))
 171
 172 (defmethod handle-config-preference ((name (eql :log-pathname))
 173                                      args)
 174   (setf *lift-report-pathname* (first args)))
 175
 176 (defmethod handle-config-preference ((name (eql :build-report))
 177                                      args)
 178   (declare (ignore args))
 179   (let* ((dest (or (test-result-property *test-result* :full-pathname)
 180                    (asdf:system-relative-pathname
 181                     (or (test-result-property *test-result* :relative-to)
 182                         'lift)
 183                     (or (test-result-property *test-result* :name)
 184                         "report.html"))))
 185          (format (or (test-result-property *test-result* :format)
 186                      :html))
 187          (unique-name (test-result-property *test-result* :unique-name)))
 188     (when (and unique-name (not (streamp dest)))
 189         (setf dest (unique-filename dest)))
 190     (with-standard-io-syntax
 191       (let ((*print-readably* nil))
 192         (handler-bind
 193             ((error
 194               (lambda (c)
 195                 (format *debug-io*
 196                         "Error ~a while generating report (format ~s) to ~a"
 197                         c format dest)
 198                 (format *debug-io*
 199                         "~%~%Backtrace~%~%~s"
 200                         (get-backtrace c)))))
 201           (cond
 202             ((or (streamp dest) (writable-directory-p dest))
 203              (format *debug-io* "~&Sending report (format ~s) to ~a"
 204                      format dest)
 205              (test-result-report
 206               *test-result*
 207               dest
 208               format))
 209             (t
 210              (format *debug-io* "~&Unable to write report (format ~s) to ~a"
 211                      format dest))))))))
 212