dev/config.lisp

   1 (in-package #:lift)
   2
   3 #|
   4 (:report-property :if-exists :supersede)
   5 (:report-property :unique-name nil)
   6 (:report-property :format :html)
   7 (:report-property :name "index")
   8 (:report-property :relative-to db.agraph.tests)
   9
  10 For text based reports like :describe, the report name is the filename
  11 where the report is placed or a stream (e.g., *standard-output*).
  12
  13 The :name property specifies the name and type.
  14
  15 There are three ways to specify the directory:
  16
  17 1. :full-name
  18 2. :relative-to
  19 3. the current directory (via *default-pathname-defaults*)
  20
  21 If :full-name is a pathname with a name and type, then these will be
  22 used rather than :name. If :unique-name is true (and the destination
  23 is not a stream), then the date and an integer tag will be added to the
  24 name. E.g., the path `/tmp/lift-tests/report.txt` will become
  25 `/tmp/lift-tests/report-2009-02-01-1.txt`.
  26
  27
  28 For HTML, The report name specifies a _directory_. The :name property
  29 is ignored.
  30
  31 There are three ways to specify the directory location.
  32
  33 1. :full-name
  34 2. :relative-to
  35 3. the current directory (via *default-pathname-defaults*)
  36
  37 In all cases, the report will go into
  38
  39 |#
  40
  41 (defun show-test-warning (message &rest args)
  42   (apply #'format *error-output* message args))
  43
  44 (defgeneric generate-report-summary-pathname ()
  45   )
  46
  47 (defgeneric handle-config-preference (name args)
  48   )
  49
  50 (defvar *current-configuration-stream* nil)
  51
  52 (defvar *current-asdf-system-name* nil
  53   "Holds the name of the system being tested when using the `:generic`
  54 configuration.
  55
  56 LIFT needs this to run the `:generic` configuration because this is
  57 how it determines which configuration file to load. If you use
  58 `asdf:test-op` then this value will be set automatically.
  59 Otherwise, you will need to set it yourself.")
  60
  61 (eval-when (:load-toplevel :execute)
  62   (when (find-package :asdf)
  63     (defmethod asdf:perform :around ((operation asdf:test-op) (c asdf:system))
  64       (let ((*current-asdf-system-name* (asdf:component-name c)))
  65         (call-next-method)))))
  66
  67 (defun lift-relative-pathname (pathname &optional (errorp nil))
  68   "Merges pathname with either the path to the currently loading system
  69 \(if there is one\) or the *default-pathname-defaults*."
  70   (let* ((asdf-package (find-package :asdf))
  71          (srp-symbol (and asdf-package
  72                           (find-symbol (symbol-name 'system-relative-pathname)
  73                                        asdf-package)))
  74          (srp (and *current-asdf-system-name* srp-symbol)))
  75     (labels ((try-it (path)
  76                (let ((pathname (merge-pathnames pathname path)))
  77                  (if errorp (and pathname (probe-file pathname)) pathname))))
  78       (or (and srp (try-it (funcall srp *current-asdf-system-name* "")))
  79           (try-it *default-pathname-defaults*)
  80           (not errorp)
  81           (and (not asdf-package)
  82                (error "Unable to use :generic configuration option because ASDF is not loaded."))
  83           (and (not srp-symbol)
  84                (error "Unable to use :generic configuration option because asdf:system-relative-pathname is not function bound (maybe try updating ASDF?)"))
  85           (and (not *current-asdf-system-name*)
  86                (error "Unable to use :generic configuration option
  87 because the current system cannot be determined. You can either
  88 use asdf:test-op or bind *current-asdf-system-name* yourself."))))))
  89
  90 (defun find-generic-test-configuration (&optional (errorp nil))
  91   (flet ((try-it (path)
  92            (and path (probe-file path))))
  93     (or (try-it (lift-relative-pathname "lift-local.config" errorp))
  94         (try-it (lift-relative-pathname "lift-standard.config" errorp))
  95         (and errorp
  96              (error "Unable to use :generic configuration file neither lift-local.config nor lift-standard.config can be found.")))))
  97
  98 (defun report-summary-pathname ()
  99   (unique-filename (generate-report-summary-pathname)))
 100
 101 (defmethod generate-report-summary-pathname ()
 102   (lift-relative-pathname "test-results/summary.sav"))
 103
 104 #+(or)
 105 (generate-report-summary-pathname)
 106
 107 (defun run-tests-from-file (path)
 108   (let ((real-path (cond ((eq path :generic)
 109                           (setf path
 110                                 (find-generic-test-configuration t)))
 111                          (t
 112                           (probe-file path)))))
 113     (unless real-path
 114       (error "Unable to find configuration file ~s" path))
 115     (setf *test-result*
 116           (let* ((*package* *package*)
 117                  (*read-eval* nil)
 118                  (result (make-test-result path :multiple))
 119                  (*lift-dribble-pathname* nil)
 120                  (*lift-debug-output* *debug-io*)
 121                  (*lift-standard-output* *standard-output*)
 122                  (*test-break-on-errors?* nil)
 123                  (*test-run-subsuites?* t)
 124                  (*lift-equality-test* 'equal)
 125                  (*test-print-length* :follow-print)
 126                  (*test-print-level* :follow-print)
 127                  (*lift-if-dribble-exists* :append)
 128                  (*test-result* result))
 129             (%run-tests-from-file path)))))
 130
 131 (defun %run-tests-from-file (path)
 132   (with-open-file (*current-configuration-stream* path
 133                                                   :direction :input
 134                                                   :if-does-not-exist :error)
 135     (let ((form nil)
 136           (run-tests-p t))
 137       (loop while (not (eq (setf form (read *current-configuration-stream*
 138                                             nil :eof nil)) :eof))
 139          collect
 140          (handler-bind
 141              ((error (lambda (c) (format
 142                                   *error-output*
 143                                   "Error while running ~a from ~a: ~a"
 144                                   form path c)
 145                              (pprint (get-backtrace c))
 146                              (invoke-debugger c))))
 147            (format t "~&handle config: ~s" form)
 148            (destructuring-bind
 149                  (name &rest args)
 150                form
 151              (assert (typep name 'symbol) nil
 152                      "Each command must be a symbol and ~s is not." name)
 153              (setf args (massage-arguments args))
 154              (cond
 155                ;; check for preferences first (i.e., keywords)
 156                ((eq (symbol-package name)
 157                     (symbol-package :keyword))
 158                 ;; must be a preference
 159                 (handle-config-preference name args))
 160                ((and run-tests-p (find-testsuite name :errorp nil))
 161                 (multiple-value-bind (_ restartedp)
 162                     (restart-case
 163                         (if (find-testsuite name :errorp nil)
 164                             (run-tests :suite name
 165                                        :result *test-result*
 166                                        :testsuite-initargs args)
 167                             (show-test-warning
 168                              "~&Warning: testsuite ~s not found, skipping" name))
 169                       (cancel-testing-from-configuration (result)
 170                         :report (lambda (stream)
 171                                   (format stream "Cancel testing from file ~a"
 172                                           path))
 173                         (declare (ignore result))
 174                         (values nil t)))
 175                     #+(or)
 176                     (with-simple-restart (cancel-testing-from-configuration
 177                                           "Cancel testing from file ~a" path)
 178                       (if (find-testsuite name :errorp nil)
 179                           (run-tests :suite name
 180                                      :result *test-result*
 181                                      :testsuite-initargs args)
 182                           (show-test-warning
 183                            "~&Warning: testsuite ~s not found, skipping" name)))
 184                   (declare (ignore _))
 185                   ;; no more testing; continue to process commands
 186                   (when restartedp
 187                     (setf run-tests-p nil))))
 188                (t
 189                 (show-test-warning
 190                  "Don't understand '~s' while reading from ~s"
 191                  form path))))))))
 192   (values *test-result*))
 193
 194 (defun massage-arguments (args)
 195   (loop for arg in args collect
 196        (cond ((and (symbolp arg)
 197                    (string= (symbol-name arg) (symbol-name '*standard-output*)))
 198               *standard-output*)
 199              (t arg))))
 200
 201 (defmethod handle-config-preference ((name t) args)
 202   (show-test-warning "Unknown preference ~s (with arguments ~s)"
 203                      name args))
 204
 205 (defmethod handle-config-preference ((name (eql :include)) args)
 206   (%run-tests-from-file (merge-pathnames (ensure-string (first args))
 207                                          *current-configuration-stream*)))
 208
 209 (defconfig-variable :dribble *lift-dribble-pathname*)
 210
 211 (defconfig-variable :debug-output *lift-debug-output*)
 212
 213 (defconfig-variable :standard-output *lift-standard-output*)
 214
 215 (defconfig-variable :break-on-errors? *test-break-on-errors?*)
 216
 217 (defconfig-variable :do-children? *test-run-subsuites?*)
 218
 219 (defconfig-variable :equality-test *lift-equality-test*)
 220
 221 (defconfig-variable :print-length *test-print-length*)
 222
 223 (defconfig-variable :print-level *test-print-level*)
 224
 225 (defconfig-variable :print-suite-names *test-print-testsuite-names*)
 226
 227 (defconfig-variable :print-test-case-names *test-print-test-case-names*)
 228
 229 (defconfig-variable :if-dribble-exists *lift-if-dribble-exists*)
 230
 231 (defmethod handle-config-preference ((name (eql :report-property))
 232                                      args)
 233   (setf (test-result-property *test-result* (first args)) (second args)))
 234
 235 (defconfig-variable :profiling-threshold *profiling-threshold*)
 236
 237 (defconfig-variable :count-calls-p *count-calls-p*)
 238
 239 (defconfig-variable :log-pathname *lift-report-pathname*)
 240
 241 (defconfig-variable :maximum-failures *test-maximum-failure-count*)
 242 (defconfig-variable :maximum-failure-count *test-maximum-failure-count*)
 243
 244 (defconfig-variable :maximum-errors *test-maximum-error-count*)
 245 (defconfig-variable :maximum-error-count *test-maximum-error-count*)
 246
 247 (defgeneric report-pathname (method &optional result))
 248
 249 (defmethod report-pathname :around ((method (eql :html))
 250                                     &optional (result *test-result*))
 251   (cond ((and (test-result-property result :full-pathname)
 252               (streamp (test-result-property result :full-pathname)))
 253          (call-next-method))
 254         (t
 255          (let ((old-name (test-result-property result :name))
 256                (old-full-pathname (test-result-property result :full-pathname))
 257                (old-unique-name (test-result-property result :unique-name)))
 258            (unwind-protect
 259                 (progn
 260                   (setf (test-result-property result :name) t
 261                         (test-result-property result :unique-name) nil)
 262                   (let ((destination (pathname-sans-name+type (call-next-method))))
 263                     (when old-name
 264                       (setf destination
 265                             (merge-pathnames
 266                              (make-pathname :directory `(:relative ,old-name))
 267                              destination)))
 268                     (print destination)
 269                     (merge-pathnames
 270                      (make-pathname :name "index" :type "html")
 271                      (pathname-sans-name+type
 272                       (if old-unique-name
 273                           (unique-directory destination)
 274                           destination)))))
 275              (setf (test-result-property result :name) old-name
 276                    (test-result-property result :full-pathname)
 277                    old-full-pathname
 278                    (test-result-property result :unique-name)
 279                    old-unique-name))))))
 280
 281 #+(or)
 282 (defmethod report-pathname :around ((method t) &optional (result *test-result*))
 283   "Make sure that directories exist"
 284   (let ((output (call-next-method)))
 285     (cond ((streamp output)
 286            output)
 287           (t
 288            (ensure-directories-exist output)
 289            output))))
 290
 291 (defmethod report-pathname ((method t) &optional (result *test-result*))
 292   (let* ((given-report-name (test-result-property result :name))
 293          (report-type (string-downcase
 294                        (ensure-string
 295                         (test-result-property result :format))))
 296          (report-name (or (and given-report-name
 297                                (not (eq given-report-name t))
 298                                (merge-pathnames
 299                                 given-report-name
 300                                 (make-pathname :type report-type)))
 301                           (format nil "report.~a" report-type)))
 302          (via nil)
 303          (dest (or (and (setf via :full-pathname)
 304                         (test-result-property result :full-pathname)
 305                         (streamp
 306                          (test-result-property result :full-pathname))
 307                         (test-result-property result :full-pathname))
 308                    (and (setf via :full-pathname)
 309                         (test-result-property result :full-pathname)
 310                         (not (streamp
 311                               (test-result-property result :full-pathname)))
 312                         (cond ((eq given-report-name t)
 313                                (test-result-property result :full-pathname))
 314                               ((null given-report-name)
 315                                (merge-pathnames
 316                                 (test-result-property result :full-pathname)
 317                                 report-name))
 318                               (t
 319                                (merge-pathnames
 320                                 (test-result-property result :full-pathname)
 321                                 given-report-name))))
 322                    (and (setf via :relative-to)
 323                         (let ((relative-to
 324                                (test-result-property result :relative-to)))
 325                           (and relative-to
 326                                (asdf:find-system relative-to nil)
 327                                (asdf:system-relative-pathname
 328                                 relative-to report-name))))
 329                    (and (setf via :current-directory)
 330                         (merge-pathnames
 331                          (make-pathname :defaults report-name)))))
 332          (unique-name? (test-result-property result :unique-name)))
 333     (values
 334      (if (and unique-name? (not (streamp dest)))
 335          (unique-filename dest)
 336          dest)
 337      via)))
 338
 339 (defmethod handle-config-preference ((name (eql :build-report))
 340                                      args)
 341   (declare (ignore args))
 342   (let* ((format (or (test-result-property *test-result* :format)
 343                      :html))
 344          (dest (report-pathname format *test-result*)))
 345     (with-standard-io-syntax
 346       (let ((*print-readably* nil))
 347         (handler-bind
 348             ((error
 349               (lambda (c)
 350                 (format *debug-io*
 351                         "Error ~a while generating report (format ~s) to ~a"
 352                         c format dest)
 353                 (format *debug-io*
 354                         "~%~%Backtrace~%~%~s"
 355                         (get-backtrace c)))))
 356           (cond
 357             ((or (streamp dest)
 358                  (ensure-directories-exist dest)
 359                  (writable-directory-p dest))
 360              (format *debug-io* "~&Sending report (format ~s) to ~a"
 361                      format dest)
 362              (test-result-report
 363               *test-result* dest format))
 364             (t
 365              (format *debug-io* "~&Unable to write report (format ~s) to ~a"
 366                      format dest))))))))
 367
 368
 369 (defconfig :trace
 370   "Start tracing each of the arguments to :trace."
 371   (eval `(trace ,@args)))
 372
 373 (defconfig :untrace
 374   (eval `(untrace ,@args)))
 375
 376 (defconfig :skip-tests-reset
 377   (setf *skip-tests* nil))
 378
 379 (defconfig :skip-testsuites
 380   (loop for arg in args do
 381        (if (find-testsuite arg)
 382            (push arg *skip-tests*)
 383            (show-test-warning "Unable to find testsuite ~a to skip" arg))))
 384
 385 (defconfig :skip-tests
 386   (loop for arg in args do
 387        (let ((suite (if (consp arg) (first arg) arg))
 388              (test-case (if (consp arg) (second arg) nil)))
 389          (cond ((not (or (atom arg)
 390                          (= (length arg) 1) (= (length arg) 2)))
 391                 (show-test-warning
 392                  ":skip-tests takes atoms or two element lists as arguments. Ignoring ~a in ~a"
 393                  arg args))
 394                ((and (null test-case) (null (find-testsuite suite)))
 395                 (show-test-warning
 396                  "Unable to find testsuite ~a to skip" suite))
 397                ((and test-case (null (find-test-case suite test-case)))
 398                 (show-test-warning
 399                  "Unable to find test-case ~a in testsuite ~a to skip"
 400                  test-case suite))
 401                (t
 402                 (push (list suite test-case) *skip-tests*))))))