From 38f140427febf0a116915b013d11882c6fb767a6 Mon Sep 17 00:00:00 2001 From: Nathan Bird Date: Wed, 13 Jan 2010 13:41:43 -0500 Subject: [PATCH] First working edition of datasets code. --- tests/datasets.lisp | 188 ++++++++++++++++++++------------------------ 1 file changed, 87 insertions(+), 101 deletions(-) diff --git a/tests/datasets.lisp b/tests/datasets.lisp index b464d9e..114deac 100644 --- a/tests/datasets.lisp +++ b/tests/datasets.lisp @@ -6,35 +6,29 @@ ;;;; overhead, but enables simpler tests by not worrying about side-effects ;;;; between tests. ;;;; -;;;; In general datsets should be database agnostic, but because the code +;;;; In general datasets should be database agnostic, but because the code ;;;; is only run in the scope of a test, if a test is excluded for a backend ;;;; or some other reason then it is never run hence doesn't cause problems. (in-package #:clsql-tests) +(defparameter *dataset-debug-on-error* nil + "If we get an error while loading or cleaning up the dataset, +should we debug (T) or just print and quit.") + +(defun generic-error (e) + (when (and *dataset-debug-on-error* + *debugger-hook*) + (invoke-debugger e)) + (print e *error-output*) + (throw 'quit-dataset e)) + (defmacro def-dataset (name &body body) "Define a dataset" ;;probably just shove this into a param, perhaps a marginal ;; bit of processing first. `(defparameter ,name ',body)) -;;incomplete example taken from test-init -(def-dataset *employees* - (:setup "CREATE TABLE EMPLOYEES ( -emplid int not null, -groupid int not null, -married boolean not null, -first_name varchar (50), -last_name varchar (50))" )) -;;alternatively setup can still be done as -;;(:setup #'(lambda () (create-view-from-class ...))) - (:data "employees" - (:columns "emplid,groupid,married,height,first_name,last_name") - (:values "1,1,false,1.5,'Napolean', 'Bonaparte'") - (:values (format nil "1,1,true,~a,'Vladimir','Lenin'" (1+ (random 1.00))))) - (:cleanup "DROP TABLE EMPLOYEES")) - - (defmacro with-dataset (name &body body) "Use a dataset in a dynamic scope, e.g. a single test. 1. Before the body: @@ -42,103 +36,95 @@ last_name varchar (50))" )) * :data is loaded 2. Body 3. :cleanup always happens" - `(unwind-protect - (progn (%dataset-init ,name) - ,@body) - (handler-case (%dataset-cleanup ,name) - (error #'print-the-error)) ;;recursive error catch - )) + `(catch 'quit-dataset + (unwind-protect + (progn + (restart-case (%dataset-init ,name) + (retry-dataset-init () + :report ,(format nil "Retry dataset('~a) init: (with any dataset changes)" + (symbol-name name)) + (%dataset-init ,name))) + ,@body) + (%dataset-cleanup ,name)))) (defun %dataset-dispatch (arg) "For use with def-dataset and with-dataset, tries to DWIM." (etypecase arg - (string (clsql-sys:execute-command arg)) ;;treat it as a sql command. - ((or function symbol) (funcall fn)) ;;run functions - (list (mapc #'%dataset-dispatch arg)))) ;;lists are implicity progn + (string (clsql-sys:execute-command arg)) ;treat it as a sql command. + ((or function symbol) (funcall arg)) ;run functions + (list + (case (first arg) + ((function lambda) (%dataset-dispatch (eval arg))) ;#' forms, lambdas + (progn (mapc #'%dataset-dispatch (rest arg))) ; (progn "asdf" "ff") + (ignore-errors (ignore-errors (mapc #'%dataset-dispatch (rest arg)))) + (t (mapc #'%dataset-dispatch arg))) ;otherwise implicit progn + ))) (defun %dataset-init (name) "Run initialization code and fill database for given dataset." - (let ((setup (find :setup name :key #'first)) - (data (find :data name :key #'first))) - (when setup - (%dataset-dispatch setup)) - (when data - ;;run raw sql insert statements, - ;; other schemes can be done as a function in setup. - ;; most likely implemented with something like - (let (table-name columns values-list) ;gather components - (dolist (v values-list) - (clsql-sys:execute-command - (format nil "INSERT INTO ~a (~a) VALUES (~a)" - table-name columns v))))))) + (handler-bind + ((error #'generic-error)) + ;;find items that looks like '(:setup ...), + ;; dispatch the rest. + (let ((setup (rest (find :setup name :key #'first))) + (sqldata (rest (find :sqldata name :key #'first))) + (objdata (rest (find :objdata name :key #'first)))) + (when setup + (%dataset-dispatch setup)) + (when sqldata + ;;run raw sql insert statements + (destructuring-bind (table-name columns &rest values-list) sqldata + (dolist (v values-list) + (clsql-sys:execute-command + (format nil + "INSERT INTO ~a (~a) VALUES (~a)" + table-name columns v))))) + (when objdata + ;;presumed to be view-class objects, force them to insert. + (dolist (o objdata) + (setf (slot-value o 'clsql-sys::view-database) nil) + (clsql-sys:update-records-from-instance o)))))) (defun %dataset-cleanup (name) "Run cleanup code associated with the given dataset." - (%dataset-dispatch (find :cleanup name))) + (restart-case + (handler-bind ((error #'generic-error)) + (let ((cleanup (rest (find :cleanup name :key #'first)))) + (when cleanup + (%dataset-dispatch cleanup)))) + (retry-dataset-cleanup () + :report "Retry dataset cleanup (with any dataset changes)" + (%dataset-cleanup name)) + (skip-cleanup () nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Example Test Code -;;example old test -(deftest :oodml/select/1 - (mapcar #'(lambda (e) (slot-value e 'last-name)) - (clsql:select 'employee :order-by [last-name] :flatp t :caching nil)) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) - -;;just wrap in the with-dataset -(deftest :oodml/select/1 - (with-dataset (*employees*) - (mapcar #'(lambda (e) (slot-value e 'last-name)) - (clsql:select 'employee :order-by [last-name] - :flatp t :caching nil))) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) - - -;;old -(deftest :oodml/update-records/4 - (flet ((print-fresh-node () - (let ((base (car (clsql:select 'node - :where [= 1 [slot-value 'node 'node-id]] - :flatp t :caching nil)))) - (format nil "~a ~a" - (slot-value base 'node-id) - (slot-value base 'title))))) - (values - (print-fresh-node) ;ensure that data is correct when we start - (let ((base (car (clsql:select 'node - :where [= 1 [slot-value 'node 'node-id]] - :flatp t :caching nil)))) - (setf (slot-value base 'title) "Altered title") - ;;modify and check - (clsql:update-records-from-instance base) - (print-fresh-node)) - (let ((base (car (clsql:select 'node - :where [= 1 [slot-value 'node 'node-id]] - :flatp t :caching nil)))) - (setf (slot-value base 'title) "Bare node") - ;;modify back to the original and check - (clsql:update-records-from-instance base) - (print-fresh-node)))) - "1 Bare node" - "1 Altered title" - "1 Bare node") +;;incomplete example taken from test-init +;; (def-dataset *employees* +;; (:setup "CREATE TABLE employee +;; ( +;; emplid integer NOT NULL, +;; groupid integer NOT NULL, +;; first_name character varying(30), +;; last_name character varying(30), +;; email character varying(100), +;; ecompanyid integer, +;; managerid integer, +;; height double, +;; married boolean, +;; birthday timestamp without time zone, +;; bd_utime bigint, +;; CONSTRAINT employeepk PRIMARY KEY (emplid, groupid), +;; CONSTRAINT employee_emplid_key UNIQUE (emplid) +;; ) +;; ") +;; ;;alternatively setup can still be done as +;; ;;(:setup #'(lambda () (create-view-from-class ...))) +;; (:sqldata "employees" "emplid,groupid,married,height,first_name,last_name" +;; "1,1,false,1.5,'Napolean', 'Bonaparte'" +;; (format nil "1,1,true,~a,'Vladimir','Lenin'" (1+ (random 1.00)))) +;; (:cleanup "DROP TABLE EMPLOYEES")) -;;rewritten -(deftest :oodml/update-records/4 - (flet ((get-node () - (clsql:select 'node :where [= 1 [node-id]] - :flatp t :caching nil))) - (with-dataset (*nodes*) - (values - (let ((base (get-node))) - (setf (slot-value base 'title) "Altered title") - (clsql:update-records-from-instance base) - (setf base (get-node)) - (format nil "~a ~a" - (slot-value base 'node-id) - (slot-value base 'title)))))) - "1 Altered title") -- 2.34.1