tests/datasets.lisp

   1 ;;;; Proposed new file in clsql-tests to enable abstracting datasets for reuse.
   2 ;;;;
   3 ;;;; The core is def-datset and with-dataset that respectively define a set,
   4 ;;;; and enable one for a dynamic scope. Datasets will normally be setup and
   5 ;;;; torn down in the scope of one test, which may impose a computation
   6 ;;;; overhead, but enables simpler tests by not worrying about side-effects
   7 ;;;; between tests.
   8 ;;;;
   9 ;;;; In general datasets should be database agnostic, but because the code
  10 ;;;; is only run in the scope of a test, if a test is excluded for a backend
  11 ;;;; or some other reason then it is never run hence doesn't cause problems.
  12
  13 (in-package #:clsql-tests)
  14
  15 (defparameter *dataset-debug-on-error* nil
  16   "If we get an error while loading or cleaning up the dataset,
  17 should we debug (T) or just print and quit.")
  18
  19 (defun generic-error (e)
  20   (when (and *dataset-debug-on-error*
  21              *debugger-hook*)
  22     (invoke-debugger e))
  23   (fresh-line *error-output*)
  24   (princ e *error-output*)
  25   (throw 'quit-dataset e))
  26
  27 (defmacro def-dataset (name &body body)
  28   "Define a dataset"
  29   ;;probably just shove this into a param, perhaps a marginal
  30   ;; bit of processing first.
  31   `(defparameter ,name ',body))
  32
  33 (defmacro with-dataset (name &body body)
  34   "Use a dataset in a dynamic scope, e.g. a single test.
  35 1. Before the body:
  36   * :setup is run
  37   * :data is loaded
  38 2. Body
  39 3. :cleanup always happens"
  40   `(catch 'quit-dataset
  41      (unwind-protect
  42           (progn
  43             (restart-case (%dataset-init ,name)
  44               (retry-dataset-init ()
  45                 :report ,(format nil "Retry dataset('~a) init: (with any dataset changes)"
  46                                 (symbol-name name))
  47                 (%dataset-init ,name))
  48               (skip-this-test ()
  49                 :report "FAIL and run the next test"
  50                 (throw 'quit-dataset :data-set-failure)))
  51             ,@body)
  52        (%dataset-cleanup ,name))))
  53
  54
  55 (defun %dataset-dispatch (arg)
  56   "For use with def-dataset and with-dataset, tries to DWIM."
  57   (etypecase arg
  58     (string (clsql-sys:execute-command arg))  ;treat it as a sql command.
  59     ((or function symbol) (funcall arg))       ;run functions
  60     (list
  61        (case (first arg)
  62          ((function lambda) (%dataset-dispatch (eval arg))) ;#' forms, lambdas
  63          (progn (mapc #'%dataset-dispatch (rest arg)))    ; (progn "asdf" "ff")
  64          (ignore-errors (ignore-errors (mapc #'%dataset-dispatch (rest arg))))
  65          (t (mapc #'%dataset-dispatch arg)))    ;otherwise implicit progn
  66        )))
  67
  68 (defun %dataset-init (name)
  69   "Run initialization code and fill database for given dataset."
  70   ;;find items that looks like '(:setup ...),
  71   ;; dispatch the rest.
  72   (let ((*backend-warning-behavior*
  73           (typecase *default-database*
  74             (clsql-sys:generic-postgresql-database
  75              :ignore)
  76             (t *backend-warning-behavior*)))
  77         (setup (rest (find :setup name :key #'first)))
  78         (sqldata (rest (find :sqldata name :key #'first)))
  79         (objdata (rest (find :objdata name :key #'first))))
  80     (when setup
  81       (handler-bind ((warning
  82                        (lambda (c)
  83                          (when (eql :ignore *backend-warning-behavior*)
  84                            (muffle-warning c)))))
  85         (%dataset-dispatch setup)))
  86     (when sqldata
  87       ;;run raw sql insert statements
  88       (destructuring-bind (table-name columns &rest values-list) sqldata
  89         (dolist (v values-list)
  90           (clsql-sys:execute-command
  91            (format nil
  92                    "INSERT INTO ~a (~a) VALUES (~a)"
  93                    table-name columns v)))))
  94     (when objdata
  95       ;;presumed to be view-class objects, force them to insert.
  96       (dolist (o objdata)
  97         (setf (slot-value o 'clsql-sys::view-database) nil)
  98         (clsql-sys:update-records-from-instance o)))))
  99
 100 (defun %dataset-cleanup (name)
 101   "Run cleanup code associated with the given dataset."
 102   (restart-case
 103       (handler-bind ((error #'generic-error))
 104         (let ((cleanup (rest (find :cleanup name :key #'first))))
 105           (when cleanup
 106             (%dataset-dispatch cleanup))))
 107     (retry-dataset-cleanup ()
 108       :report "Retry dataset cleanup (with any dataset changes)"
 109       (%dataset-cleanup name))
 110     (skip-cleanup () nil)))
 111
 112
 113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 114 ;;; Example Test Code
 115
 116 ;;incomplete example taken from test-init
 117 ;; (def-dataset *employees*
 118 ;;   (:setup "CREATE TABLE employee
 119 ;; (
 120 ;;   emplid integer NOT NULL,
 121 ;;   groupid integer NOT NULL,
 122 ;;   first_name character varying(30),
 123 ;;   last_name character varying(30),
 124 ;;   email character varying(100),
 125 ;;   ecompanyid integer,
 126 ;;   managerid integer,
 127 ;;   height double,
 128 ;;   married boolean,
 129 ;;   birthday timestamp without time zone,
 130 ;;   bd_utime bigint,
 131 ;;   CONSTRAINT employeepk PRIMARY KEY (emplid, groupid),
 132 ;;   CONSTRAINT employee_emplid_key UNIQUE (emplid)
 133 ;; )
 134 ;; ")
 135 ;;   ;;alternatively setup can still be done as
 136 ;;   ;;(:setup #'(lambda () (create-view-from-class ...)))
 137 ;;   (:sqldata "employees" "emplid,groupid,married,height,first_name,last_name"
 138 ;;          "1,1,false,1.5,'Napolean', 'Bonaparte'"
 139 ;;          (format nil "1,1,true,~a,'Vladimir','Lenin'" (1+ (random 1.00))))
 140 ;;   (:cleanup "DROP TABLE EMPLOYEES"))
 141