X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=tests%2Ftest-init.lisp;h=2f36da21643a81458c34872dd227a8085f37d422;hb=d26a044593b10e62d1ba1c7b80266f55bc100d5d;hp=feee1d5ff328b9499ac31017536dfedc396bef28;hpb=dfc357251d94b2d93ffc79f6d979769066dc8f52;p=clsql.git diff --git a/tests/test-init.lisp b/tests/test-init.lisp index feee1d5..2f36da2 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -34,24 +34,22 @@ ((extraterrestrial :initform nil :initarg :extraterrestrial))) (def-view-class person (thing) - ((height :db-kind :base :accessor height :type float :nulls-ok t + ((height :db-kind :base :accessor height :type float :initarg :height) - (married :db-kind :base :accessor married :type boolean :nulls-ok t + (married :db-kind :base :accessor married :type boolean :initarg :married) - (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday) + (birthday :type clsql-base:wall-time :initarg :birthday) (hobby :db-kind :virtual :initarg :hobby :initform nil))) (def-view-class employee (person) ((emplid :db-kind :key :db-constraints :not-null - :nulls-ok nil :type integer :initarg :emplid) (groupid :db-kind :key :db-constraints :not-null - :nulls-ok nil :type integer :initarg :groupid) (first-name @@ -65,7 +63,6 @@ (email :accessor employee-email :type (string 100) - :nulls-ok t :initarg :email) (companyid :type integer) @@ -77,8 +74,7 @@ :foreign-key companyid :set nil)) (managerid - :type integer - :nulls-ok t) + :type integer) (manager :accessor employee-manager :db-kind :join @@ -121,6 +117,29 @@ (:base-table company)) +(def-view-class address () + ((emplid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :emplid) + (street-number + :type integer + :initarg :street-number) + (street-name + :type (string 30) + :void-value "" + :initarg :street-name) + (city + :column "city_field" + :void-value "no city" + :type (string 30) + :initarg :city) + (postal-code + :column "zip" + :type integer + :void-value 0 + :initarg :postal-code))) (defun test-connect-to-database (db-type spec) (when (db-backend-has-create/destroy-db? db-type) @@ -156,12 +175,19 @@ (defparameter employee8 nil) (defparameter employee9 nil) (defparameter employee10 nil) +(defparameter address1 nil) +(defparameter address2 nil) (defun test-initialise-database () (test-basic-initialize) - (clsql:create-view-from-class 'employee) - (clsql:create-view-from-class 'company) + (let ((*backend-warning-behavior* + (if (member *test-database-type* '(:postgresql :postgresql-socket)) + :ignore + :warn))) + (clsql:create-view-from-class 'employee) + (clsql:create-view-from-class 'company) + (clsql:create-view-from-class 'address)) (setf company1 (make-instance 'company :companyid 1 @@ -258,8 +284,18 @@ :birthday (clsql-base:get-time) :first-name "Vladamir" :last-name "Putin" - :email "putin@soviet.org")) + :email "putin@soviet.org") + + address1 (make-instance 'address + :emplid 1 + :street-number 10 + :street-name "Park Place" + :city "Leningrad" + :postal-code 123) + address2 (make-instance 'address + :emplid 2)) + ;; sleep to ensure birthdays are no longer at current time (sleep 2) @@ -297,25 +333,31 @@ (clsql:update-records-from-instance employee8) (clsql:update-records-from-instance employee9) (clsql:update-records-from-instance employee10) - (clsql:update-records-from-instance company1)) + (clsql:update-records-from-instance company1) + (clsql:update-records-from-instance address1) + (clsql:update-records-from-instance address2)) (defvar *error-count* 0) (defvar *error-list* nil) -(defun run-tests-append-report-file (report-file) - (let* ((report-path (etypecase report-file +(defun run-function-append-report-file (function report-file) + (let* ((report-path (etypecase report-file (pathname report-file) (string (parse-namestring report-file)))) (sexp-report-path (make-pathname :defaults report-path :type "sexp"))) - (with-open-file (rs report-path :direction :output - :if-exists :append + (with-open-file (rs report-path :direction :output + :if-exists :append :if-does-not-exist :create) - (with-open-file (srs sexp-report-path :direction :output - :if-exists :append - :if-does-not-exist :create) - (run-tests :report-stream rs :sexp-report-stream srs))))) - + (with-open-file (srs sexp-report-path :direction :output + :if-exists :append + :if-does-not-exist :create) + (funcall function :report-stream rs :sexp-report-stream srs))))) + +(defun run-tests-append-report-file (report-file) + (run-function-append-report-file 'run-tests report-file)) + + (defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil)) (let ((specs (read-specs)) (*report-stream* report-stream) @@ -336,35 +378,39 @@ (when (db-type-spec db-type specs) (clsql:initialize-database-type :database-type db-type)))) -(defun do-tests-for-backend (db-type spec) - (test-connect-to-database db-type spec) - - (unwind-protect - (multiple-value-bind (test-forms skip-tests) - (compute-tests-for-backend db-type *test-database-underlying-type*) - - (format *report-stream* - "~& +(defun write-report-banner (report-type db-type stream) + (format stream + "~& ****************************************************************************** -*** CLSQL Test Suite begun at ~A +*** CLSQL ~A begun at ~A *** ~A *** ~A on ~A *** Database ~A backend~A. ****************************************************************************** -" - (clsql-base:format-time - nil - (clsql-base:utime->time (get-universal-time))) - (lisp-implementation-type) - (lisp-implementation-version) - (machine-type) - db-type - (if (not (eq db-type *test-database-underlying-type*)) - (format nil " with underlying type ~A" - *test-database-underlying-type*) - "") - ) - +" + report-type + (clsql-base:format-time + nil + (clsql-base:utime->time (get-universal-time))) + (lisp-implementation-type) + (lisp-implementation-version) + (machine-type) + db-type + (if (not (eq db-type *test-database-underlying-type*)) + (format nil " with underlying type ~A" + *test-database-underlying-type*) + "") + )) + +(defun do-tests-for-backend (db-type spec) + (test-connect-to-database db-type spec) + + (unwind-protect + (multiple-value-bind (test-forms skip-tests) + (compute-tests-for-backend db-type *test-database-underlying-type*) + + (write-report-banner "Test Suite" db-type *report-stream*) + (test-initialise-database) (regression-test:rem-all-tests) @@ -397,6 +443,7 @@ (defun compute-tests-for-backend (db-type db-underlying-type) + (declare (ignorable db-type)) (let ((test-forms '()) (skip-tests '())) (dolist (test-form (append (test-basic-forms) @@ -405,23 +452,23 @@ (let ((test (second test-form))) (cond ((and (null (db-type-has-views? db-underlying-type)) - (clsql-base-sys::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4)) + (clsql-base::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4)) (push (cons test "views not supported") skip-tests)) ((and (null (db-type-has-boolean-where? db-underlying-type)) - (clsql-base-sys::in test :fdml/select/11 :oodml/select/5)) + (clsql-base::in test :fdml/select/11 :oodml/select/5)) (push (cons test "boolean where not supported") skip-tests)) ((and (null (db-type-has-subqueries? db-underlying-type)) - (clsql-base-sys::in test :fdml/select/5 :fdml/select/10)) + (clsql-base::in test :fdml/select/5 :fdml/select/10)) (push (cons test "subqueries not supported") skip-tests)) ((and (null (db-type-transaction-capable? db-underlying-type *default-database*)) - (clsql-base-sys::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4)) + (clsql-base::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4)) (push (cons test "transactions not supported") skip-tests)) ((and (null (db-type-has-fancy-math? db-underlying-type)) - (clsql-base-sys::in test :fdml/select/1)) + (clsql-base::in test :fdml/select/1)) (push (cons test "fancy math not supported") skip-tests)) ((and (eql *test-database-type* :sqlite) - (clsql-base-sys::in test :fddl/view/4 :fdml/select/10)) + (clsql-base::in test :fddl/view/4 :fdml/select/10)) (push (cons test "not supported by sqlite") skip-tests)) (t (push test-form test-forms)))))