From: Kevin Rosenberg Date: Wed, 20 Jan 2010 21:49:00 +0000 (-0700) Subject: Merge branch 'dataset-refactoring' of git://github.com/UnwashedMeme/clsql X-Git-Tag: v4.3.0^0 X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=4f42e6bf168107ce0ffd9ed0ca0316d00301b11d;hp=45a14426276623daeaa595294bcc343595cdc15d;p=clsql.git Merge branch 'dataset-refactoring' of git://github.com/UnwashedMeme/clsql --- diff --git a/.gitignore b/.gitignore index ee7d837..12f84fe 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ configure-stamp build-stamp *~ +*.fasl diff --git a/clsql-tests.asd b/clsql-tests.asd index 9d4df2f..4bd56e6 100644 --- a/clsql-tests.asd +++ b/clsql-tests.asd @@ -32,6 +32,9 @@ :components ((:file "package") (:file "utils") (:file "test-init") + (:file "datasets") + (:file "ds-employees") + (:file "ds-nodes") (:file "benchmarks") (:file "test-internal") (:file "test-basic") diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index 8f39471..849fb39 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -761,5 +761,8 @@ #+(or mysql-client-v4.1 mysql-client-v5) t #-(or mysql-client-v4.1 mysql-client-v5) nil) +(defmethod db-type-has-auto-increment? ((db-type (eql :mysql))) + t) + (when (clsql-sys:database-type-library-loaded :mysql) (clsql-sys:initialize-database-type :database-type :mysql)) diff --git a/sql/db-interface.lisp b/sql/db-interface.lisp index 031d1e8..ae586e8 100644 --- a/sql/db-interface.lisp +++ b/sql/db-interface.lisp @@ -374,6 +374,12 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.") t) (:documentation "T [default] if database-type supports EXCEPT.")) +(defgeneric db-type-has-auto-increment? (db-type) + (:method (db-type) + (declare (ignore db-type) + nil)) + (:documentation "NIL [default] if database-type supports auto-incrementing columns.")) + ;;; Large objects support (Marc Battyani) (defgeneric database-create-large-object (database) diff --git a/sql/package.lisp b/sql/package.lisp index fbb67b4..fbf8257 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -153,6 +153,7 @@ #:db-type-use-fully-qualified-column-on-drop-index? #:db-type-has-intersect? #:db-type-has-except? + #:db-type-has-auto-increment? #:database-underlying-type #:database-get-type-specifier #:read-sql-value diff --git a/tests/benchmarks.lisp b/tests/benchmarks.lisp index a39f49b..66dfb3e 100644 --- a/tests/benchmarks.lisp +++ b/tests/benchmarks.lisp @@ -42,7 +42,6 @@ (defun do-benchmarks-for-backend (db-type spec count) (test-connect-to-database db-type spec) - (test-initialise-database) (write-report-banner "Benchmarks" db-type *report-stream*) (create-view-from-class 'bench) @@ -68,17 +67,19 @@ (time (dotimes (i n) (query "SELECT * FROM BENCH" :field-names nil))) - (format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL IMMEDIATE ***~%") - (time - (dotimes (i (truncate n 10)) - (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) - (format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL DEFERRED ***~%") - (let* ((slotdef (find 'address (clsql-sys::class-slots (find-class 'employee-address)) - :key #'clsql-sys::slot-definition-name)) - (dbi (when slotdef (clsql-sys::view-class-slot-db-info slotdef)))) - (setf (gethash :retrieval dbi) :deferred) + (with-dataset *ds-employees* + (format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL IMMEDIATE ***~%") (time (dotimes (i (truncate n 10)) - (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) - (setf (gethash :retrieval dbi) :immediate)))) + (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) + + (format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL DEFERRED ***~%") + (let* ((slotdef (find 'address (clsql-sys::class-slots (find-class 'employee-address)) + :key #'clsql-sys::slot-definition-name)) + (dbi (when slotdef (clsql-sys::view-class-slot-db-info slotdef)))) + (setf (gethash :retrieval dbi) :deferred) + (time + (dotimes (i (truncate n 10)) + (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) + (setf (gethash :retrieval dbi) :immediate))))) diff --git a/tests/datasets.lisp b/tests/datasets.lisp new file mode 100644 index 0000000..114deac --- /dev/null +++ b/tests/datasets.lisp @@ -0,0 +1,130 @@ +;;;; Proposed new file in clsql-tests to enable abstracting datasets for reuse. +;;;; +;;;; The core is def-datset and with-dataset that respectively define a set, +;;;; and enable one for a dynamic scope. Datasets will normally be setup and +;;;; torn down in the scope of one test, which may impose a computation +;;;; overhead, but enables simpler tests by not worrying about side-effects +;;;; between tests. +;;;; +;;;; 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)) + +(defmacro with-dataset (name &body body) + "Use a dataset in a dynamic scope, e.g. a single test. +1. Before the body: + * :setup is run + * :data is loaded +2. Body +3. :cleanup always happens" + `(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 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." + (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." + (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 + +;;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")) + diff --git a/tests/ds-employees.lisp b/tests/ds-employees.lisp new file mode 100644 index 0000000..6c464d1 --- /dev/null +++ b/tests/ds-employees.lisp @@ -0,0 +1,398 @@ +(in-package #:clsql-tests) + +#.(clsql:locally-enable-sql-reader-syntax) +(defparameter company1 nil) +(defparameter employee1 nil) +(defparameter employee2 nil) +(defparameter employee3 nil) +(defparameter employee4 nil) +(defparameter employee5 nil) +(defparameter employee6 nil) +(defparameter employee7 nil) +(defparameter employee8 nil) +(defparameter employee9 nil) +(defparameter employee10 nil) +(defparameter address1 nil) +(defparameter address2 nil) +(defparameter employee-address1 nil) +(defparameter employee-address2 nil) +(defparameter employee-address3 nil) +(defparameter employee-address4 nil) +(defparameter employee-address5 nil) + +(defclass thing () + ((extraterrestrial :initform nil :initarg :extraterrestrial))) + +(def-view-class person (thing) + ((height :db-kind :base :accessor height :type float + :initarg :height) + (married :db-kind :base :accessor married :type boolean + :initarg :married) + (birthday :type clsql:wall-time :initarg :birthday) + (bd-utime :type clsql:universal-time :initarg :bd-utime) + (hobby :db-kind :virtual :initarg :hobby :initform nil))) + +(def-view-class employee (person) + ((emplid + :db-kind :key + :db-constraints (:not-null :unique) + :type integer + :initarg :emplid) + (groupid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (first-name + :accessor first-name + :type (varchar 30) + :initarg :first-name) + (last-name + :accessor last-name + :type (varchar 30) + :initarg :last-name) + (email + :accessor employee-email + :type (varchar 100) + :initarg :email) + (ecompanyid + :type integer + :initarg :companyid) + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key ecompanyid + :foreign-key companyid + :set nil)) + (managerid + :type integer + :initarg :managerid) + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil)) + (addresses + :accessor employee-addresses + :db-kind :join + :db-info (:join-class employee-address + :home-key emplid + :foreign-key aemplid + :target-slot address + :set t))) + (:base-table employee)) + +(def-view-class company () + ((companyid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (groupid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (name + :type (varchar 100) + :initarg :name) + (presidentid + :type integer + :initarg :presidentid) + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key (companyid groupid) + :foreign-key (ecompanyid groupid) + :set t)))) + +(def-view-class address () + ((addressid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :addressid) + (street-number + :type integer + :initarg :street-number) + (street-name + :type (varchar 30) + :void-value "" + :initarg :street-name) + (city + :column "city_field" + :void-value "no city" + :type (varchar 30) + :initarg :city) + (postal-code + :column zip + :type integer + :void-value 0 + :initarg :postal-code)) + (:base-table addr)) + +;; many employees can reside at many addressess +(def-view-class employee-address () + ((aemplid :type integer :initarg :emplid) + (aaddressid :type integer :initarg :addressid) + (verified :type boolean :initarg :verified) + (address :db-kind :join + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :immediate)) + (employee :db-kind :join + :db-info (:join-class employee + :home-key aemplid + :foreign-key emplid + :retrieval :immediate))) + (:base-table "ea_join")) + +(def-view-class deferred-employee-address () + ((aemplid :type integer :initarg :emplid) + (aaddressid :type integer :initarg :addressid) + (verified :type boolean :initarg :verified) + (address :db-kind :join + :db-info (:join-class address + :home-key aaddressid + :foreign-key addressid + :retrieval :deferred + :set nil))) + (:base-table "ea_join")) + + + +(defun initialize-ds-employees () + ;; (start-sql-recording :type :both) + (let ((*backend-warning-behavior* + (if (member *test-database-type* '(:postgresql :postgresql-socket)) + :ignore + :warn))) + (mapc #'clsql:create-view-from-class + '(employee company address employee-address))) + + + (setq *test-start-utime* (get-universal-time)) + (let* ((*db-auto-sync* t) + (now-time (clsql:utime->time *test-start-utime*))) + (setf company1 (make-instance 'company + :presidentid 1 + :companyid 1 + :groupid 1 + :name "Widgets Inc.") + employee1 (make-instance 'employee + :emplid 1 + :groupid 1 + :married t + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Vladimir" + :last-name "Lenin" + :email "lenin@soviet.org" + :companyid 1) + employee2 (make-instance 'employee + :emplid 2 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org" + :managerid 1 + :companyid 1) + employee3 (make-instance 'employee + :emplid 3 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Leon" + :last-name "Trotsky" + :email "trotsky@soviet.org" + :managerid 1 + :companyid 1) + employee4 (make-instance 'employee + :emplid 4 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Nikita" + :last-name "Kruschev" + :email "kruschev@soviet.org" + :managerid 1 + :companyid 1) + employee5 (make-instance 'employee + :emplid 5 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Leonid" + :last-name "Brezhnev" + :email "brezhnev@soviet.org" + :managerid 1 + :companyid 1) + employee6 (make-instance 'employee + :emplid 6 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Yuri" + :last-name "Andropov" + :email "andropov@soviet.org" + :managerid 1 + :companyid 1) + employee7 (make-instance 'employee + :emplid 7 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Konstantin" + :last-name "Chernenko" + :email "chernenko@soviet.org" + :managerid 1 + :companyid 1) + employee8 (make-instance 'employee + :emplid 8 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Mikhail" + :last-name "Gorbachev" + :email "gorbachev@soviet.org" + :managerid 1 + :companyid 1) + employee9 (make-instance 'employee + :emplid 9 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Boris" + :last-name "Yeltsin" + :email "yeltsin@soviet.org" + :managerid 1 + :companyid 1) + employee10 (make-instance 'employee + :emplid 10 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :bd-utime *test-start-utime* + :birthday now-time + :first-name "Vladimir" + :last-name "Putin" + :email "putin@soviet.org" + :managerid 1 + :companyid 1) + address1 (make-instance 'address + :addressid 1 + :street-number 10 + :street-name "Park Place" + :city "Leningrad" + :postal-code 123) + address2 (make-instance 'address + :addressid 2) + employee-address1 (make-instance 'employee-address + :emplid 1 + :addressid 1 + :verified t) + employee-address2 (make-instance 'employee-address + :emplid 2 + :addressid 2 + :verified t) + employee-address3 (make-instance 'employee-address + :emplid 3 + :addressid 1 + :verified nil) + employee-address4 (make-instance 'employee-address + :emplid 1 + :addressid 2 + :verified nil) + employee-address5 (make-instance 'employee-address + :emplid 3 + :addressid 2))) + + ;; sleep to ensure birthdays are no longer at current time + ;(sleep 1) ;want to find the test that depends on it, put the sleep there. + + #|| + ;; Lenin manages everyone ; + (clsql:add-to-relation employee2 'manager employee1) + (clsql:add-to-relation employee3 'manager employee1) + (clsql:add-to-relation employee4 'manager employee1) + (clsql:add-to-relation employee5 'manager employee1) + (clsql:add-to-relation employee6 'manager employee1) + (clsql:add-to-relation employee7 'manager employee1) + (clsql:add-to-relation employee8 'manager employee1) + (clsql:add-to-relation employee9 'manager employee1) + (clsql:add-to-relation employee10 'manager employee1) + ;; Everyone works for Widgets Inc. ; + (clsql:add-to-relation company1 'employees employee1) + (clsql:add-to-relation company1 'employees employee2) + (clsql:add-to-relation company1 'employees employee3) + (clsql:add-to-relation company1 'employees employee4) + (clsql:add-to-relation company1 'employees employee5) + (clsql:add-to-relation company1 'employees employee6) + (clsql:add-to-relation company1 'employees employee7) + (clsql:add-to-relation company1 'employees employee8) + (clsql:add-to-relation company1 'employees employee9) + (clsql:add-to-relation company1 'employees employee10) + ;; Lenin is president of Widgets Inc. ; + (clsql:add-to-relation company1 'president employee1) + ||# + + ;; store these instances + #|| + (clsql:update-records-from-instance employee1) + (clsql:update-records-from-instance employee2) + (clsql:update-records-from-instance employee3) + (clsql:update-records-from-instance employee4) + (clsql:update-records-from-instance employee5) + (clsql:update-records-from-instance employee6) + (clsql:update-records-from-instance employee7) + (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 address1) + (clsql:update-records-from-instance address2) + ||# + ) + + + (def-dataset *ds-employees* + (:setup initialize-ds-employees) + (:cleanup (lambda () + (mapc #'clsql-sys:drop-view-from-class + '(employee company address employee-address)) + (ignore-errors + (clsql-sys:execute-command "DROP TABLE ea_join"))))) + +#.(clsql:restore-sql-reader-syntax-state) + diff --git a/tests/ds-nodes.lisp b/tests/ds-nodes.lisp new file mode 100644 index 0000000..7a8c8a6 --- /dev/null +++ b/tests/ds-nodes.lisp @@ -0,0 +1,117 @@ +(in-package #:clsql-tests) + +#.(clsql:locally-enable-sql-reader-syntax) + +(defparameter basenode nil) +(defparameter derivednode1 nil) +(defparameter derivednode2 nil) +(defparameter node nil) +(defparameter setting1 nil) +(defparameter setting2 nil) +(defparameter user1 nil) +(defparameter user2 nil) +(defparameter theme1 nil) +(defparameter theme2 nil) +(defparameter loc1 nil) +(defparameter loc2 nil) +(defparameter subloc1 nil) +(defparameter subloc2 nil) + + + +;; classes for testing the normalisedp stuff +(def-view-class node () + ((node-id :accessor node-id :initarg :node-id + :type integer :db-kind :key + :db-constraints (:not-null :auto-increment)) + (title :accessor title :initarg :title :type (varchar 240)) + (createtime :accessor createtime :initarg :createtime :type wall-time + :db-constraints (:not-null) :initform (get-time)) + (modifiedtime :accessor modifiedtime :initarg :modifiedtime :type wall-time + :initform (make-time :year 1900 :month 1 :day 1)))) + +(def-view-class setting (node) + ((setting-id :accessor setting-id :initarg :setting-id + :type integer :db-kind :key :db-constraints (:not-null)) + (vars :accessor vars :initarg :vars :type (varchar 240))) + (:normalisedp t)) + +(def-view-class user (node) + ((user-id :accessor user-id :initarg :user-id + :type integer :db-kind :key :db-constraints (:not-null)) + (nick :accessor nick :initarg :nick :type (varchar 64))) + (:normalisedp t)) + +(def-view-class theme (setting) + ((theme-id :accessor theme-id :initarg :theme-id + :type integer :db-kind :key :db-constraints (:not-null)) + (doc :accessor doc :initarg :doc :type (varchar 240))) + (:normalisedp t)) + +;; A class that uses only a superclass db table +(def-view-class location (node) + () + (:base-table node) + (:normalisedp t)) + +(def-view-class subloc (location) + ((subloc-id :accessor subloc-id :initarg :subloc-id + :type integer :db-kind :key :db-constraints (:not-null)) + (loc :accessor loc :initarg :loc :type (varchar 64))) + (:normalisedp t)) + + + +(defun initialize-ds-nodes () + ;; (start-sql-recording :type :both) + (let ((*backend-warning-behavior* + (if (member *test-database-type* '(:postgresql :postgresql-socket)) + :ignore + :warn))) + (mapc #'clsql:create-view-from-class + '(node setting user theme location subloc))) + + (setq *test-start-utime* (get-universal-time)) + (let* ((*db-auto-sync* t)) + (setf node (make-instance 'node + :title "Bare node") + setting1 (make-instance 'setting + :title "Setting1" + :vars "var 1") + setting2 (make-instance 'setting + :title "Setting2" + :vars "var 2") + user1 (make-instance 'user + :title "user-1" + :nick "first user") + user2 (make-instance 'user + :title "user-2" + :nick "second user") + theme1 (make-instance 'theme + :title "theme-1" + :vars "empty" + :doc "first theme") + theme2 (make-instance 'theme + :title "theme-2" + :doc "second theme") + loc1 (make-instance 'location + :title "location-1") + loc2 (make-instance 'location + :title "location-2") + subloc1 (make-instance 'subloc + :title "subloc-1" + :loc "a subloc") + subloc2 (make-instance 'subloc + :title "subloc-2" + :loc "second subloc")))) + + + + + (def-dataset *ds-nodes* + (:setup initialize-ds-nodes) + (:cleanup (lambda () + (mapc #'clsql-sys:drop-view-from-class + '(node setting user theme location subloc))))) + +#.(clsql:restore-sql-reader-syntax-state) diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index cbcd8fa..03ed1e1 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -18,206 +18,222 @@ (in-package #:clsql-tests) + (setq *rt-basic* '( (deftest :basic/type/1 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) - results) - (destructuring-bind (int float str) row - (push (list (integerp int) - (typep float 'double-float) - (stringp str)) - results)))) + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float str) row + (push (list (integerp int) + (typep float 'double-float) + (stringp str)) + results))))) ((t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t))) - (deftest :basic/type/2 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) - results) - (destructuring-bind (int float str) row - (setq results - (cons (list (double-float-equal - (transform-float-1 int) - float) - (double-float-equal - (parse-double str) - float)) - results)))) - results) - ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) - - (deftest :basic/select/1 - (let ((rows (query "select * from TYPE_TABLE" :result-types :auto))) - (values - (length rows) - (length (car rows)))) + (deftest :basic/type/2 + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types :auto) + results) + (destructuring-bind (int float str) row + (setq results + (cons (list (double-float-equal + (transform-float-1 int) + float) + (double-float-equal + (parse-double str) + float)) + results)))) + results)) + ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) + + (deftest :basic/select/1 + (with-dataset *ds-basic* + (let ((rows (query "select * from TYPE_TABLE" :result-types :auto))) + (values + (length rows) + (length (car rows))))) 11 3) (deftest :BASIC/SELECT/2 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types nil) - results) - (destructuring-bind (int float str) row - (push (list (stringp int) - (stringp float) - (stringp str)) - results)))) + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float str) row + (push (list (stringp int) + (stringp float) + (stringp str)) + results))))) ((t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t) (t t t))) (deftest :basic/select/3 - (let ((results '())) - (dolist (row (query "select * from TYPE_TABLE" :result-types nil) - results) - (destructuring-bind (int float str) row - (push (list (double-float-equal - (transform-float-1 (parse-integer int)) - (parse-double float)) - (double-float-equal - (parse-double str) - (parse-double float))) - results)))) + (with-dataset *ds-basic* + (let ((results '())) + (dolist (row (query "select * from TYPE_TABLE" :result-types nil) + results) + (destructuring-bind (int float str) row + (push (list (double-float-equal + (transform-float-1 (parse-integer int)) + (parse-double float)) + (double-float-equal + (parse-double str) + (parse-double float))) + results))))) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) (deftest :basic/map/1 - (let ((results '()) - (rows (map-query 'vector #'identity "select * from TYPE_TABLE" - :result-types nil))) - (declare (type (simple-array list (*)) rows)) - (dotimes (i (length rows) results) - (push - (list - (listp (aref rows i)) - (length (aref rows i)) - (eql (- i 5) - (parse-integer (first (aref rows i)) - :junk-allowed nil)) - (double-float-equal - (transform-float-1 (parse-integer (first (aref rows i)))) - (parse-double (second (aref rows i))))) - results))) + (with-dataset *ds-basic* + (let ((results '()) + (rows (map-query 'vector #'identity "select * from TYPE_TABLE" + :result-types nil))) + (declare (type (simple-array list (*)) rows)) + (dotimes (i (length rows) results) + (push + (list + (listp (aref rows i)) + (length (aref rows i)) + (eql (- i 5) + (parse-integer (first (aref rows i)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (aref rows i)))) + (parse-double (second (aref rows i))))) + results)))) ((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t))) (deftest :basic/map/2 - (let ((results '()) - (rows (map-query 'list #'identity "select * from TYPE_TABLE" - :result-types nil))) - (dotimes (i (length rows) results) - (push - (list - (listp (nth i rows)) - (length (nth i rows)) - (eql (- i 5) - (parse-integer (first (nth i rows)) - :junk-allowed nil)) - (double-float-equal - (transform-float-1 (parse-integer (first (nth i rows)))) - (parse-double (second (nth i rows))))) - results))) + (with-dataset *ds-basic* + (let ((results '()) + (rows (map-query 'list #'identity "select * from TYPE_TABLE" + :result-types nil))) + (dotimes (i (length rows) results) + (push + (list + (listp (nth i rows)) + (length (nth i rows)) + (eql (- i 5) + (parse-integer (first (nth i rows)) + :junk-allowed nil)) + (double-float-equal + (transform-float-1 (parse-integer (first (nth i rows)))) + (parse-double (second (nth i rows))))) + results)))) ((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t))) (deftest :basic/map/3 - (let ((results '()) - (rows (map-query 'list #'identity "select * from TYPE_TABLE" - :result-types :auto))) - (dotimes (i (length rows) results) - (push - (list - (listp (nth i rows)) - (length (nth i rows)) - (eql (- i 5) - (first (nth i rows))) - (double-float-equal - (transform-float-1 (first (nth i rows))) - (second (nth i rows)))) - results))) + (with-dataset *ds-basic* + (let ((results '()) + (rows (map-query 'list #'identity "select * from TYPE_TABLE" + :result-types :auto))) + (dotimes (i (length rows) results) + (push + (list + (listp (nth i rows)) + (length (nth i rows)) + (eql (- i 5) + (first (nth i rows))) + (double-float-equal + (transform-float-1 (first (nth i rows))) + (second (nth i rows)))) + results)))) ((t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t) (t 3 t t))) ;; confirm that a query on a single element returns a list of one element (deftest :basic/map/4 - (let ((rows (map-query 'list #'identity "select t_int from TYPE_TABLE" - :result-types nil))) - (values - (consp (first rows)) - (length (first rows)))) + (with-dataset *ds-basic* + (let ((rows (map-query 'list #'identity "select t_int from TYPE_TABLE" + :result-types nil))) + (values + (consp (first rows)) + (length (first rows))))) t 1) (deftest :basic/do/1 - (let ((results '())) - (do-query ((int float str) "select * from TYPE_TABLE" :result-types nil) - (let ((int-number (parse-integer int))) - (setq results - (cons (list (double-float-equal (transform-float-1 - int-number) - (parse-double float)) - (double-float-equal (parse-double str) - (parse-double float))) - results)))) - results) + (with-dataset *ds-basic* + (let ((results '())) + (do-query ((int float str) "select * from TYPE_TABLE" :result-types nil) + (let ((int-number (parse-integer int))) + (setq results + (cons (list (double-float-equal (transform-float-1 + int-number) + (parse-double float)) + (double-float-equal (parse-double str) + (parse-double float))) + results)))) + results)) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) (deftest :basic/do/2 - (let ((results '())) - (do-query ((int float str) "select * from TYPE_TABLE" :result-types :auto) - (setq results - (cons - (list (double-float-equal - (transform-float-1 int) - float) - (double-float-equal - (parse-double str) - float)) - results))) - results) + (with-dataset *ds-basic* + (let ((results '())) + (do-query ((int float str) "select * from TYPE_TABLE" :result-types :auto) + (setq results + (cons + (list (double-float-equal + (transform-float-1 int) + float) + (double-float-equal + (parse-double str) + float)) + results))) + results)) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) (deftest :basic/bigint/1 - (let ((results '())) - (dolist (row (query "select * from TYPE_BIGINT" :result-types :auto) - results) - (destructuring-bind (int bigint) row - (push (list (integerp int) - (if (and (eq :odbc *test-database-type*) - (eq :postgresql *test-database-underlying-type*)) - ;; ODBC/Postgresql may return returns bigints as strings or integer - ;; depending upon the platform - t - (integerp bigint))) - results)))) + (with-dataset *ds-bigint* + (let ((results '())) + (dolist (row (query "select * from TYPE_BIGINT" :result-types :auto) + results) + (destructuring-bind (int bigint) row + (push (list (integerp int) + (if (and (eq :odbc *test-database-type*) + (eq :postgresql *test-database-underlying-type*)) + ;; ODBC/Postgresql may return returns bigints as strings or integer + ;; depending upon the platform + t + (integerp bigint))) + results))))) ((t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t) (t t))) )) -(defun test-basic-initialize () - (ignore-errors - (clsql:execute-command "DROP TABLE TYPE_TABLE") - (clsql:execute-command "DROP TABLE TYPE_BIGINT")) - - (clsql:execute-command - "CREATE TABLE TYPE_TABLE (t_int integer, t_float double precision, t_str VARCHAR(30))") - - (if (clsql-sys:db-type-has-bigint? *test-database-type*) - (clsql:execute-command "CREATE TABLE TYPE_BIGINT (t_int integer, t_bigint BIGINT)") - (clsql:execute-command "CREATE TABLE TYPE_BIGINT (t_int integer)")) - - (dotimes (i 11) - (let* ((test-int (- i 5)) - (test-flt (transform-float-1 test-int))) - (clsql:execute-command - (format nil "INSERT INTO TYPE_TABLE VALUES (~a,~a,'~a')" - test-int - (clsql-sys:number-to-sql-string test-flt) - (clsql-sys:number-to-sql-string test-flt) - )) - (when (clsql-sys:db-type-has-bigint? *test-database-type*) - (clsql:execute-command - (format nil "INSERT INTO TYPE_BIGINT VALUES (~a,~a)" - test-int - (transform-bigint-1 test-int) - )))))) +(def-dataset *ds-basic* + (:setup (lambda () + (ignore-errors + (clsql:execute-command "DROP TABLE TYPE_TABLE") + (clsql:execute-command "DROP TABLE TYPE_BIGINT")) + + (clsql:execute-command + "CREATE TABLE TYPE_TABLE (t_int integer, t_float double precision, t_str VARCHAR(30))") + + (dotimes (i 11) + (let* ((test-int (- i 5)) + (test-flt (transform-float-1 test-int))) + (clsql:execute-command + (format nil "INSERT INTO TYPE_TABLE VALUES (~a,~a,'~a')" + test-int + (clsql-sys:number-to-sql-string test-flt) + (clsql-sys:number-to-sql-string test-flt) + )))))) + (:cleanup "DROP TABLE TYPE_TABLE")) + +(def-dataset *ds-bigint* + (:setup (lambda () + (ignore-errors (clsql:execute-command "DROP TABLE TYPE_BIGINT")) + (clsql:execute-command "CREATE TABLE TYPE_BIGINT (T_INT integer, T_BIGINT BIGINT)") + (dotimes (i 11) + (clsql:execute-command + (format nil "INSERT INTO TYPE_BIGINT VALUES (~a,~a)" + (- i 5) + (transform-bigint-1 (- i 5))))))) + (:cleanup "DROP TABLE TYPE_BIGINT")) ;;;; Testing functions @@ -234,9 +250,9 @@ (defun double-float-equal (a b) (if (zerop a) (if (zerop b) - t - nil) + t + nil) (let ((diff (abs (/ (- a b) a)))) - (if (> diff (* 10 double-float-epsilon)) - nil - t)))) + (if (> diff (* 10 double-float-epsilon)) + nil + t)))) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index e3dc1b2..446c2f2 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -19,44 +19,52 @@ #.(clsql:locally-enable-sql-reader-syntax) +(def-dataset *ds-fddl* + (:setup ("CREATE TABLE ALPHA (A integer, B integer, C varchar (30), d date, f float)" + "CREATE TABLE BRAVO (jack integer, jill integer)")) + (:sqldata "ALPHA" "A,B,C,d,f" + "1,1,'asdf','2010-01-01',3.14" + "2,1,'blarg','2012-12-21',0.1") + (:cleanup "DROP TABLE ALPHA" "DROP TABLE BRAVO")) + (setq *rt-fddl* '( ;; list current tables (deftest :fddl/table/1 - (sort (mapcar #'string-downcase - (clsql:list-tables :owner *test-database-user*)) - #'string<) - ("addr" "big" "company" "ea_join" "employee" "node" "setting" - "subloc" "theme" "type_bigint" "type_table" "user")) + (with-dataset *ds-fddl* + (sort (mapcar #'string-downcase + (clsql:list-tables :owner *test-database-user*)) + #'string<)) + ("alpha" "bravo")) ;; create a table, test for its existence, drop it and test again (deftest :fddl/table/2 (progn (clsql:create-table [foo] - '(([id] integer) - ([height] float) - ([name] (string 24)) - ([comments] longchar))) - (values - (clsql:table-exists-p [foo] :owner *test-database-user*) - (progn - (clsql:drop-table [foo] :if-does-not-exist :ignore) - (clsql:table-exists-p [foo] :owner *test-database-user*)))) + '(([id] integer) + ([height] float) + ([name] (string 24)) + ([comments] longchar))) + (values + (clsql:table-exists-p [foo] :owner *test-database-user*) + (progn + (clsql:drop-table [foo] :if-does-not-exist :ignore) + (clsql:table-exists-p [foo] :owner *test-database-user*)))) t nil) ;; create a table, list its attributes and drop it (deftest :fddl/table/3 (apply #'values - (progn (clsql:create-table [foo] - '(([id] integer) - ([height] float) - ([name] (char 255)) - ([comments] longchar))) - (prog1 - (sort (mapcar #'string-downcase - (clsql:list-attributes [foo])) - #'string<) - (clsql:drop-table [foo] :if-does-not-exist :ignore)))) + (progn (clsql:create-table [foo] + '(([id] integer) + ([height] float) + ([name] (char 255)) + ([comments] longchar))) + (prog1 + (sort (mapcar #'string-downcase + (clsql:list-attributes [foo])) + #'string<) + (clsql:drop-table [foo] :if-does-not-exist :ignore)))) "comments" "height" "id" "name") (deftest :fddl/table/4 @@ -72,11 +80,11 @@ (deftest :fddl/table/5 (prog1 - (progn - (clsql:create-table "MyMixedCase" '(([a] integer))) - (clsql:execute-command "insert into \"MyMixedCase\" values (5)") - (clsql:insert-records :into "MyMixedCase" :values '(6)) - (clsql:select [a] :from "MyMixedCase" :order-by '((a :asc)))) + (progn + (clsql:create-table "MyMixedCase" '(([a] integer))) + (clsql:execute-command "insert into \"MyMixedCase\" values (5)") + (clsql:insert-records :into "MyMixedCase" :values '(6)) + (clsql:select [a] :from "MyMixedCase" :order-by '((a :asc)))) (clsql:drop-table "MyMixedCase")) ((5) (6))) @@ -85,17 +93,17 @@ (clsql:table-exists-p [foo]) (progn (let ((*backend-warning-behavior* - (if (member *test-database-type* - '(:postgresql :postgresql-socket)) - :ignore - :warn))) - (case *test-database-underlying-type* - (:mssql (clsql:create-table [foo] - '(([bar] integer :not-null :primary-key) - ([baz] string :not-null :unique)))) - (t (clsql:create-table [foo] - '(([bar] integer :not-null :unique :primary-key) - ([baz] string :not-null :unique)))))) + (if (member *test-database-type* + '(:postgresql :postgresql-socket)) + :ignore + :warn))) + (case *test-database-underlying-type* + (:mssql (clsql:create-table [foo] + '(([bar] integer :not-null :primary-key) + ([baz] string :not-null :unique)))) + (t (clsql:create-table [foo] + '(([bar] integer :not-null :unique :primary-key) + ([baz] string :not-null :unique)))))) (clsql:table-exists-p [foo])) (progn (clsql:drop-table [foo]) @@ -107,14 +115,14 @@ (clsql:table-exists-p [foo]) (progn (let ((*backend-warning-behavior* - (if (member *test-database-type* - '(:postgresql :postgresql-socket)) - :ignore - :warn))) - (clsql:create-table [foo] '(([bar] integer :not-null) - ([baz] string :not-null)) - :constraints '("UNIQUE (bar,baz)" - "PRIMARY KEY (bar)"))) + (if (member *test-database-type* + '(:postgresql :postgresql-socket)) + :ignore + :warn))) + (clsql:create-table [foo] '(([bar] integer :not-null) + ([baz] string :not-null)) + :constraints '("UNIQUE (bar,baz)" + "PRIMARY KEY (bar)"))) (clsql:table-exists-p [foo])) (progn (clsql:drop-table [foo]) @@ -123,143 +131,158 @@ (deftest :fddl/attributes/1 (apply #'values - (sort - (mapcar #'string-downcase - (clsql:list-attributes [employee] - :owner *test-database-user*)) - #'string<)) - "bd_utime" "birthday" "ecompanyid" "email" "emplid" "first_name" "groupid" "height" - "last_name" "managerid" "married") + (with-dataset *ds-fddl* + (sort + (mapcar #'string-downcase + (clsql:list-attributes [alpha] :owner *test-database-user*)) + #'string<))) + "a" "b" "c" "d" "f") (deftest :fddl/attributes/2 - (apply #'values - (sort - (mapcar #'(lambda (a) (string-downcase (car a))) - (clsql:list-attribute-types [employee] - :owner *test-database-user*)) - #'string<)) - "bd_utime" "birthday" "ecompanyid" "email" "emplid" "first_name" "groupid" "height" - "last_name" "managerid" "married") + (with-dataset *ds-fddl* + (apply #'values + (sort + (mapcar #'(lambda (a) (string-downcase (car a))) + (clsql:list-attribute-types [alpha] + :owner *test-database-user*)) + #'string<))) + "a" "b" "c" "d" "f") ;; Attribute types are vendor specific so need to test a range (deftest :fddl/attributes/3 - (and (member (clsql:attribute-type [emplid] [employee]) '(:int :integer :int4 :number)) t) + (with-dataset *ds-fddl* + (and (member (clsql:attribute-type [a] [alpha]) '(:int :integer :int4 :number)) t)) t) (deftest :fddl/attributes/4 - (multiple-value-bind (type length scale nullable) - (clsql:attribute-type [first-name] [employee]) - (values (clsql-sys:in type :varchar :varchar2) length scale nullable)) + (with-dataset *ds-fddl* + (multiple-value-bind (type length scale nullable) + (clsql:attribute-type [c] [alpha]) + (values (clsql-sys:in type :varchar :varchar2) length scale nullable))) t 30 nil 1) (deftest :fddl/attributes/5 - (and (member (clsql:attribute-type [birthday] [employee]) '(:datetime :timestamp :date)) t) + (with-dataset *ds-fddl* + (and (member (clsql:attribute-type [d] [alpha]) '(:datetime :timestamp :date)) t)) t) (deftest :fddl/attributes/6 - (and (member (clsql:attribute-type [height] [employee]) '(:float :float8 :number)) t) + (with-dataset *ds-fddl* + (and (member (clsql:attribute-type [f] [alpha]) '(:float :float8 :number)) t)) t) (deftest :fddl/attributes/7 - (and (member (clsql:attribute-type [bd_utime] [employee]) '(:bigint :int8 :char)) t) + (with-dataset *ds-bigint* + (and (member (clsql:attribute-type [t_bigint] [TYPE_BIGINT]) '(:bigint :int8)) t)) t) ;; create a view, test for existence, drop it and test again (deftest :fddl/view/1 - (progn (clsql:create-view [lenins-group] - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (values - (clsql:view-exists-p [lenins-group] :owner *test-database-user*) - (progn - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) - (clsql:view-exists-p [lenins-group] :owner *test-database-user*)))) + (with-dataset *ds-fddl* + (progn (clsql:create-view [v1] + :as [select [a] [b] [c] + :from [alpha] + :where [= [a] 1]]) + (values + (clsql:view-exists-p [v1] :owner *test-database-user*) + (progn + (clsql:drop-view [v1] :if-does-not-exist :ignore) + (clsql:view-exists-p [v1] :owner *test-database-user*))))) t nil) ;; create a view, list its attributes and drop it -(when (clsql-sys:db-type-has-views? *test-database-underlying-type*) - (deftest :fddl/view/2 - (progn (clsql:create-view [lenins-group] - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (prog1 - (sort (mapcar #'string-downcase - (clsql:list-attributes [lenins-group])) - #'string<) - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore))) - ("email" "first_name" "last_name"))) +(deftest :fddl/view/2 + (with-dataset *ds-fddl* + (progn (clsql:create-view [v1] + :as [select [a] [b] [c] + :from [alpha] + :where [= [a] 1]]) + (unwind-protect + (sort (mapcar #'string-downcase + (clsql:list-attributes [v1])) + #'string<) + (clsql:drop-view [v1] :if-does-not-exist :ignore)))) + ("a" "b" "c")) ;; create a view, select stuff from it and drop it (deftest :fddl/view/3 - (progn (clsql:create-view [lenins-group] - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (let ((result - (list - ;; Shouldn't exist - (clsql:select [first-name] [last-name] [email] - :from [lenins-group] - :where [= [last-name] "Lenin"]) - ;; Should exist - (car (clsql:select [first-name] [last-name] [email] - :from [lenins-group] - :where [= [last-name] "Stalin"]))))) - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) - (apply #'values result))) - nil ("Josef" "Stalin" "stalin@soviet.org")) + (with-dataset *ds-fddl* + (progn + (clsql:create-view [v1] + :as [select [a] [b] [c] + :from [alpha] + :where [= [a] 1]]) + (unwind-protect + (let ((result + (list + ;; Shouldn't exist + (clsql:select [a] [b] [c] + :from [v1] + :where [= [a] -1]) + ;; Should exist + (car (clsql:select [a] [b] [c] + :from [v1] + :where [= [a] 1]))))) + + (apply #'values result)) + (clsql:drop-view [v1] :if-does-not-exist :ignore)))) + nil (1 1 "asdf")) (deftest :fddl/view/4 - (progn (clsql:create-view [lenins-group] - :column-list '([forename] [surname] [email]) - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (let ((result - (list - ;; Shouldn't exist - (clsql:select [forename] [surname] [email] - :from [lenins-group] - :where [= [surname] "Lenin"]) - ;; Should exist - (car (clsql:select [forename] [surname] [email] - :from [lenins-group] - :where [= [surname] "Stalin"]))))) - (clsql:drop-view [lenins-group] :if-does-not-exist :ignore) - (apply #'values result))) - nil ("Josef" "Stalin" "stalin@soviet.org")) + (with-dataset *ds-fddl* + (progn + (clsql:create-view [v1] + :column-list '([x] [y] [z]) + :as [select [a] [b] [c] + :from [alpha] + :where [= [a] 1]]) + (unwind-protect + (let ((result + (list + ;; Shouldn't exist + (clsql:select [x] [y] [z] + :from [v1] + :where [= [x] -1]) + ;; Should exist + (car (clsql:select [x] [y] [z] + :from [v1] + :where [= [x] 1]))))) + + (apply #'values result)) + (clsql:drop-view [v1] :if-does-not-exist :ignore)))) + nil (1 1 "asdf")) ;; create an index, test for existence, drop it and test again (deftest :fddl/index/1 - (progn (clsql:create-index [bar] :on [employee] :attributes - '([first-name] [last-name] [email]) :unique t) - (values - (clsql:index-exists-p [bar] :owner *test-database-user*) - (progn - (clsql:drop-index [bar] :on [employee] - :if-does-not-exist :ignore) - (clsql:index-exists-p [bar] :owner *test-database-user*)))) + (with-dataset *ds-fddl* + (progn (clsql:create-index [bar] :on [alpha] :attributes + '([a] [b] [c]) :unique t) + (values + (clsql:index-exists-p [bar] :owner *test-database-user*) + (progn + (clsql:drop-index [bar] :on [alpha] + :if-does-not-exist :ignore) + (clsql:index-exists-p [bar] :owner *test-database-user*))))) t nil) ;; create indexes with names as strings, symbols and in square brackets (deftest :fddl/index/2 - (let ((names '("foo" foo [foo])) - (result '())) - (dolist (name names) - (clsql:create-index name :on [employee] :attributes '([last-name])) - (push (clsql:index-exists-p name :owner *test-database-user*) result) - (clsql:drop-index name :on [employee] :if-does-not-exist :ignore)) - (apply #'values result)) + (with-dataset *ds-fddl* + (let ((names '("foo" foo [foo])) + (result '())) + (dolist (name names) + (clsql:create-index name :on [alpha] :attributes '([a])) + (push (clsql:index-exists-p name :owner *test-database-user*) result) + (clsql:drop-index name :on [alpha] :if-does-not-exist :ignore)) + (apply #'values result))) t t t) ;; test list-indexes with keyword :ON (deftest :fddl/index/3 (progn (clsql:create-table [i3test] '(([a] (string 10)) - ([b] integer))) + ([b] integer))) (clsql:create-index [foo] :on [i3test] :attributes '([b]) :unique nil) (clsql:create-index [bar] :on [i3test] :attributes @@ -269,25 +292,25 @@ (clsql:index-exists-p [foo]) (clsql:index-exists-p [bar]) (sort - (mapcar - #'string-downcase - (clsql:list-indexes :on [i3test] :owner *test-database-user*)) - #'string-lessp) + (mapcar + #'string-downcase + (clsql:list-indexes :on [i3test] :owner *test-database-user*)) + #'string-lessp) (progn - (clsql:drop-index [bar] :on [i3test]) - (clsql:drop-index [foo] :on [i3test]) - (clsql:drop-table [i3test]) - t))) + (clsql:drop-index [bar] :on [i3test]) + (clsql:drop-index [foo] :on [i3test]) + (clsql:drop-table [i3test]) + t))) t t t ("bar" "foo") t) ;; create an sequence, test for existence, drop it and test again (deftest :fddl/sequence/1 (progn (clsql:create-sequence [foo]) - (values - (clsql:sequence-exists-p [foo] :owner *test-database-user*) - (progn - (clsql:drop-sequence [foo] :if-does-not-exist :ignore) - (clsql:sequence-exists-p [foo] :owner *test-database-user*)))) + (values + (clsql:sequence-exists-p [foo] :owner *test-database-user*) + (progn + (clsql:drop-sequence [foo] :if-does-not-exist :ignore) + (clsql:sequence-exists-p [foo] :owner *test-database-user*)))) t nil) ;; create and increment a sequence @@ -296,8 +319,8 @@ (clsql:create-sequence [foo]) (setf val1 (clsql:sequence-next [foo])) (prog1 - (< val1 (clsql:sequence-next [foo])) - (clsql:drop-sequence [foo] :if-does-not-exist :ignore))) + (< val1 (clsql:sequence-next [foo])) + (clsql:drop-sequence [foo] :if-does-not-exist :ignore))) t) ;; explicitly set the value of a sequence @@ -306,60 +329,43 @@ (clsql:create-sequence [foo]) (clsql:set-sequence-position [foo] 5) (prog1 - (clsql:sequence-next [foo]) - (clsql:drop-sequence [foo] :if-does-not-exist :ignore))) + (clsql:sequence-next [foo]) + (clsql:drop-sequence [foo] :if-does-not-exist :ignore))) 6) -(deftest :fddl/big/1 - (let ((rows (clsql:select [*] :from [big] :order-by [i] :field-names nil))) - (values - (length rows) - (do ((i 0 (1+ i)) - (max (expt 2 60)) - (rest rows (cdr rest))) - ((= i (length rows)) t) - (let ((index (1+ i)) - (int (first (car rest))) - (bigint (second (car rest)))) - (when (and (or (eq *test-database-type* :oracle) - (and (eq *test-database-type* :odbc) - (eq *test-database-underlying-type* :postgresql))) - (stringp bigint)) - (setf bigint (parse-integer bigint))) - (unless (and (eql int index) - (eql bigint (truncate max index))) - (return nil)))))) - 555 t) + (deftest :fddl/owner/1 - (and - ;; user tables are an improper subset of all tables - (= (length (intersection (clsql:list-tables :owner nil) - (clsql:list-tables :owner :all) - :test #'string=)) - (length (clsql:list-tables :owner nil))) - ;; user tables are a proper subset of all tables - (> (length (clsql:list-tables :owner :all)) - (length (clsql:list-tables :owner nil)))) + (with-dataset *ds-fddl* + (and + ;; user tables are an improper subset of all tables + (= (length (intersection (clsql:list-tables :owner nil) + (clsql:list-tables :owner :all) + :test #'string=)) + (length (clsql:list-tables :owner nil))) + ;; user tables are a proper subset of all tables + (> (length (clsql:list-tables :owner :all)) + (length (clsql:list-tables :owner nil))))) t) (deftest :fddl/cache-table-queries/1 - (list - (gethash "EMPLOYEE" (clsql-sys::attribute-cache clsql:*default-database*)) - (progn - (clsql:cache-table-queries "EMPLOYEE" :action t) - (gethash "EMPLOYEE" (clsql-sys::attribute-cache clsql:*default-database*))) - (progn - (clsql:list-attribute-types "EMPLOYEE") - (not - (null - (cadr - (gethash "EMPLOYEE" - (clsql-sys::attribute-cache clsql:*default-database*)))))) - (progn - (clsql:cache-table-queries "EMPLOYEE" :action :flush) - (gethash "EMPLOYEE" (clsql-sys::attribute-cache clsql:*default-database*)))) - (nil (t nil) t (t nil))) + (with-dataset *ds-fddl* + (list + (gethash "ALPHA" (clsql-sys::attribute-cache clsql:*default-database*)) + (progn + (clsql:cache-table-queries "ALPHA" :action t) + (gethash "ALPHA" (clsql-sys::attribute-cache clsql:*default-database*))) + (progn + (clsql:list-attribute-types "ALPHA") + (not + (null + (cadr + (gethash "ALPHA" + (clsql-sys::attribute-cache clsql:*default-database*)))))) + (progn + (clsql:cache-table-queries "ALPHA" :action :flush) + (gethash "ALPHA" (clsql-sys::attribute-cache clsql:*default-database*))))) + (nil (t nil) t (t nil))) )) diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index f48078f..053dbc4 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -19,675 +19,771 @@ #.(clsql:locally-enable-sql-reader-syntax) +;;started defining an independent dataset that doesn't depend on the view-classes +;; but there is a *lot* of stuff in the file assuming that dataset. +;; (def-dataset *ds-fdml* +;; (:setup (lambda () +;; (let ((*backend-warning-behavior* +;; (if (member *test-database-type* '(:postgresql :postgresql-socket)) +;; :ignore +;; :warn))) +;; (clsql-sys:execute-command "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 precision, +;; married boolean, +;; birthday timestamp, +;; bd_utime bigint, +;; CONSTRAINT employeepk PRIMARY KEY (emplid, groupid), +;; CONSTRAINT employee_emplid_key UNIQUE (emplid) +;; )")))) +;; (:sqldata "EMPLOYEE" +;; "emplid,groupid,first_name,last_name,email,height,birthday" +;; "10,1,'a','b','a@b.org',1.9,current_timestamp" +;; "11,1,'x','y','x@y.org',null,current_timestamp" +;; ) +;; (:cleanup "DROP TABLE EMPLOYEE") +;; ) + (setq *rt-fdml* '( -;; inserts a record using all values only and then deletes it -(deftest :fdml/insert/1 - (let ((now (get-universal-time))) - (clsql:insert-records :into [employee] - :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" - 1 1 1.85 t ,(clsql:utime->time now) ,now)) - (values - (clsql:select [first-name] [last-name] [email] - :from [employee] :where [= [emplid] 11]) - (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) - (clsql:select [*] :from [employee] :where [= [emplid] 11])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) - -;; inserts a record using attributes and values and then deletes it -(deftest :fdml/insert/2 - (progn - (clsql:insert-records :into [employee] - :attributes '(emplid groupid first_name last_name - email ecompanyid managerid) - :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" - 1 1)) - (values - (clsql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 11]) - (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) - (clsql:select [*] :from [employee] :where [= [emplid] 11])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) - -;; inserts a record using av-pairs and then deletes it -(deftest :fdml/insert/3 - (progn - (clsql:insert-records :into [employee] - :av-pairs'((emplid 11) (groupid 1) - (first_name "Yuri") - (last_name "Gagarin") - (email "gagarin@soviet.org") - (ecompanyid 1) (managerid 1))) - (values - (clsql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 11]) - (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) - (clsql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 11])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) - -;; inserts a records using a query from another table -(deftest :fdml/insert/4 - (progn - (clsql:create-table [employee2] '(([forename] string) - ([surname] string) - ([email] string))) - (clsql:insert-records :into [employee2] - :query [select [first-name] [last-name] [email] - :from [employee]] - :attributes '(forename surname email)) - (prog1 - (equal (clsql:select [*] :from [employee2]) - (clsql:select [first-name] [last-name] [email] - :from [employee])) - (clsql:drop-table [employee2] :if-does-not-exist :ignore))) - t) - -;; updates a record using attributes and values and then deletes it -(deftest :fdml/update/1 - (progn - (clsql:update-records [employee] - :attributes '(first_name last_name email) - :values '("Yuri" "Gagarin" "gagarin@soviet.org") - :where [= [emplid] 1]) - (values - (clsql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 1]) - (progn - (clsql:update-records [employee] - :av-pairs'((first_name "Vladimir") - (last_name "Lenin") - (email "lenin@soviet.org")) - :where [= [emplid] 1]) - (clsql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 1])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) - (("Vladimir" "Lenin" "lenin@soviet.org"))) - -;; updates a record using av-pairs and then deletes it -(deftest :fdml/update/2 - (progn - (clsql:update-records [employee] - :av-pairs'((first_name "Yuri") - (last_name "Gagarin") - (email "gagarin@soviet.org")) - :where [= [emplid] 1]) - (values - (clsql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 1]) - (progn - (clsql:update-records [employee] - :av-pairs'((first_name "Vladimir") - (last_name "Lenin") - (email "lenin@soviet.org")) - :where [= [emplid] 1]) - (clsql:select [first-name] [last-name] [email] - :from [employee] :where [= [emplid] 1])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) - (("Vladimir" "Lenin" "lenin@soviet.org"))) - - ;; Computed values are not always classified as numeric by psqlodbc (deftest :fdml/query/1 - (let ((count (caar (clsql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')" :field-names nil)))) - (if (stringp count) - (nth-value 0 (parse-integer count)) - (nth-value 0 (truncate count)))) + (with-dataset *ds-employees* + (let ((count (caar (clsql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')" :field-names nil)))) + (if (stringp count) + (nth-value 0 (parse-integer count)) + (nth-value 0 (truncate count))))) 10) (deftest :fdml/query/2 - (multiple-value-bind (rows field-names) - (clsql:query - "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME") - (values rows (mapcar 'string-upcase field-names))) + (with-dataset *ds-employees* + (multiple-value-bind (rows field-names) + (clsql:query + "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME") + (values rows (mapcar 'string-upcase field-names)))) (("Leonid" "Brezhnev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") ("Josef" "Stalin") ("Leon" "Trotsky")) ("FIRST_NAME" "LAST_NAME")) (deftest :fdml/query/3 - (caar (clsql:query "SELECT EMPLID FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil)) + (with-dataset *ds-employees* + (caar (clsql:query "SELECT EMPLID FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil))) 6) (deftest :fdml/query/4 - (typep (caar (clsql:query "SELECT HEIGHT FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil)) - 'float) + (with-dataset *ds-employees* + (typep (caar (clsql:query "SELECT HEIGHT FROM EMPLOYEE WHERE LAST_NAME = 'Andropov'" :field-names nil)) + 'float)) t) (deftest :fdml/query/5 - (let ((res (clsql:query (clsql:sql [select [first-name] [sum [emplid]] :from [employee]] - [group-by [first-name]] [order-by [sum [emplid]]]) - :field-names nil :result-types nil))) - (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p))))) - res)) + (with-dataset *ds-employees* + (let ((res (clsql:query (clsql:sql [select [first-name] [sum [emplid]] :from [employee]] + [group-by [first-name]] [order-by [sum [emplid]]]) + :field-names nil :result-types nil))) + (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p))))) + res))) (("Josef" 2) ("Leon" 3) ("Nikita" 4) ("Leonid" 5) ("Yuri" 6) - ("Konstantin" 7) ("Mikhail" 8) ("Boris" 9) ("Vladimir" 11))) + ("Konstantin" 7) ("Mikhail" 8) ("Boris" 9) ("Vladimir" 11))) (deftest :fdml/query/6 - (let ((res (clsql:query (clsql:sql [union [select [emplid] :from [employee]] - [select [groupid] :from [company]]]) - :field-names nil :result-types nil :flatp t))) - (values (every #'stringp res) - (mapcar #'(lambda (f) (truncate (read-from-string f))) res))) + (with-dataset *ds-employees* + (let ((res (clsql:query (clsql:sql [union [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t + ))) + (values (every #'stringp res) + (sort (mapcar #'(lambda (f) (truncate (read-from-string f))) res) + #'<=)))) t (1 2 3 4 5 6 7 8 9 10)) (deftest :fdml/query/7 - (let ((res (car (clsql:query (clsql:sql [intersect [select [emplid] :from [employee]] - [select [groupid] :from [company]]]) - :field-names nil :result-types nil :flatp t)))) - (values (stringp res) - (nth-value 0 (truncate (read-from-string res))))) + (with-dataset *ds-employees* + (let ((res (car (clsql:query (clsql:sql [intersect [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t)))) + (values (stringp res) + (nth-value 0 (truncate (read-from-string res)))))) t 1) (deftest :fdml/query/8 - (let ((res (clsql:query (clsql:sql [except [select [emplid] :from [employee]] - [select [groupid] :from [company]]]) - :field-names nil :result-types nil :flatp t))) - (values (every #'stringp res) - (mapcar #'(lambda (f) (truncate (read-from-string f))) res))) + (with-dataset *ds-employees* + (let ((res (clsql:query (clsql:sql [except [select [emplid] :from [employee]] + [select [groupid] :from [company]]]) + :field-names nil :result-types nil :flatp t))) + (values (every #'stringp res) + (sort (mapcar #'(lambda (f) (truncate (read-from-string f))) res) + #'<=)))) t (2 3 4 5 6 7 8 9 10)) (deftest :fdml/execute-command/1 - (values - (clsql:table-exists-p [foo] :owner *test-database-user*) - (progn - (clsql:execute-command "create table foo (bar integer)") - (clsql:table-exists-p [foo] :owner *test-database-user*)) - (progn - (clsql:execute-command "drop table foo") - (clsql:table-exists-p [foo] :owner *test-database-user*))) + (with-dataset *ds-employees* + (values + (clsql:table-exists-p [foo] :owner *test-database-user*) + (progn + (clsql:execute-command "create table foo (bar integer)") + (clsql:table-exists-p [foo] :owner *test-database-user*)) + (progn + (clsql:execute-command "drop table foo") + (clsql:table-exists-p [foo] :owner *test-database-user*)))) nil t nil) ;; compare min, max and average hieghts in inches (they're quite short ;; these guys!) (deftest :fdml/select/1 - (let ((max (clsql:select [function "floor" - [/ [* [max [height]] 100] 2.54]] - :from [employee] - :result-types nil - :flatp t)) - (min (clsql:select [function "floor" - [/ [* [min [height]] 100] 2.54]] - :from [employee] - :result-types nil - :flatp t)) - (avg (clsql:select [function "floor" - [avg [/ [* [height] 100] 2.54]]] - :from [employee] - :result-types nil - :flatp t))) - (apply #'< (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) - (append min avg max)))) - t) + (with-dataset *ds-employees* + (let ((max (clsql:select [function "floor" + [/ [* [max [height]] 100] 2.54]] + :from [employee] + :result-types nil + :flatp t)) + (min (clsql:select [function "floor" + [/ [* [min [height]] 100] 2.54]] + :from [employee] + :result-types nil + :flatp t)) + (avg (clsql:select [function "floor" + [avg [/ [* [height] 100] 2.54]]] + :from [employee] + :result-types nil + :flatp t))) + (apply #'< (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) + (append min avg max))))) + t) (deftest :fdml/select/2 - (clsql:select [first-name] :from [employee] :flatp t :distinct t - :field-names nil - :result-types nil - :order-by [first-name]) - ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" - "Yuri")) + (with-dataset *ds-employees* + (clsql:select [first-name] :from [employee] :flatp t :distinct t + :field-names nil + :result-types nil + :order-by [first-name])) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" + "Yuri")) (deftest :fdml/select/3 - (let ((res (clsql:select [first-name] [count [*]] :from [employee] - :result-types nil - :group-by [first-name] - :order-by [first-name] - :field-names nil))) - (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p))))) - res)) + (with-dataset *ds-employees* + (let ((res (clsql:select [first-name] [count [*]] :from [employee] + :result-types nil + :group-by [first-name] + :order-by [first-name] + :field-names nil))) + (mapcar (lambda (p) (list (car p) (truncate (read-from-string (second p))))) + res))) (("Boris" 1) ("Josef" 1) ("Konstantin" 1) ("Leon" 1) ("Leonid" 1) ("Mikhail" 1) ("Nikita" 1) ("Vladimir" 2) ("Yuri" 1))) (deftest :fdml/select/4 - (clsql:select [last-name] :from [employee] - :where [like [email] "%org"] - :order-by [last-name] - :field-names nil - :result-types nil - :flatp t) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :where [like [email] "%org"] + :order-by [last-name] + :field-names nil + :result-types nil + :flatp t)) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/select/5 - (clsql:select [email] :from [employee] :flatp t :result-types nil - :where [in [employee emplid] - [select [managerid] :from [employee]]] - :field-names nil) + (with-dataset *ds-employees* + (clsql:select [email] :from [employee] :flatp t :result-types nil + :where [in [employee emplid] + [select [managerid] :from [employee]]] + :field-names nil)) ("lenin@soviet.org")) (deftest :fdml/select/6 - (if (clsql-sys:db-type-has-fancy-math? *test-database-underlying-type*) - (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) - (clsql:select [function "trunc" [height]] :from [employee] - :result-types nil - :field-names nil - :flatp t)) - (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) - (clsql:select [height] :from [employee] :flatp t - :field-names nil :result-types nil))) - (1 1 1 1 1 1 1 1 1 1)) + (with-dataset *ds-employees* + (if (clsql-sys:db-type-has-fancy-math? *test-database-underlying-type*) + (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) + (clsql:select [function "trunc" [height]] :from [employee] + :result-types nil + :field-names nil + :flatp t)) + (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) + (clsql:select [height] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (1 1 1 1 1 1 1 1 1 1)) (deftest :fdml/select/7 - (let ((result (car (clsql:select [max [emplid]] :from [employee] :flatp t - :field-names nil :result-types nil)))) - (values - (stringp result) - (nth-value 0 (truncate (read-from-string result))))) + (with-dataset *ds-employees* + (let ((result (car (clsql:select [max [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (values + (stringp result) + (nth-value 0 (truncate (read-from-string result)))))) t 10) (deftest :fdml/select/8 - (let ((result (car (clsql:select [min [emplid]] :from [employee] :flatp t - :field-names nil :result-types nil)))) - (values - (stringp result) - (nth-value 0 (truncate (read-from-string result))))) + (with-dataset *ds-employees* + (let ((result (car (clsql:select [min [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)))) + (values + (stringp result) + (nth-value 0 (truncate (read-from-string result)))))) t 1) (deftest :fdml/select/9 - (subseq - (car - (clsql:select [avg [emplid]] :from [employee] :flatp t - :field-names nil :result-types nil)) - 0 3) + (with-dataset *ds-employees* + (subseq + (car + (clsql:select [avg [emplid]] :from [employee] :flatp t + :field-names nil :result-types nil)) + 0 3)) "5.5") (deftest :fdml/select/10 - (clsql:select [last-name] :from [employee] - :where [not [in [emplid] - [select [managerid] :from [company]]]] - :result-types nil - :field-names nil - :flatp t - :order-by [last-name]) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" - "Trotsky" "Yeltsin")) + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :where [not [in [emplid] + [select [managerid] :from [company]]]] + :result-types nil + :field-names nil + :flatp t + :order-by [last-name])) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" + "Trotsky" "Yeltsin")) (deftest :fdml/select/11 - (clsql:select [last-name] :from [employee] :where [married] :flatp t - :field-names nil :order-by [emplid] :result-types nil) + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] :where [married] :flatp t + :field-names nil :order-by [emplid] :result-types nil)) ("Lenin" "Stalin" "Trotsky")) (deftest :fdml/select/12 - (let ((v 1)) - (clsql:select [last-name] :from [employee] :where [= [emplid] v] - :field-names nil :result-types nil)) + (with-dataset *ds-employees* + (let ((v 1)) + (clsql:select [last-name] :from [employee] :where [= [emplid] v] + :field-names nil :result-types nil))) (("Lenin"))) (deftest :fdml/select/13 - (multiple-value-bind (results field-names) - (clsql:select [emplid] [last-name] :from [employee] - :where [= [emplid] 1]) - (values results (mapcar #'string-downcase field-names))) - ((1 "Lenin")) - ("emplid" "last_name")) + (with-dataset *ds-employees* + (multiple-value-bind (results field-names) + (clsql:select [emplid] [last-name] :from [employee] + :where [= [emplid] 1]) + (values results (mapcar #'string-downcase field-names)))) + ((1 "Lenin")) + ("emplid" "last_name")) (deftest :fdml/select/14 - (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] - :flatp t))) + (with-dataset *ds-employees* + (floatp (car (clsql:select [height] :from [employee] :where [= [emplid] 1] + :flatp t)))) t) (deftest :fdml/select/15 - (multiple-value-bind (rows field-names) - (clsql:select [addressid] [street-number] [street-name] [city_field] [zip] - :from [addr] - :where [= 1 [addressid]]) - (values - rows - (mapcar #'string-downcase field-names))) + (with-dataset *ds-employees* + (multiple-value-bind (rows field-names) + (clsql:select [addressid] [street-number] [street-name] [city_field] [zip] + :from [addr] + :where [= 1 [addressid]]) + (values + rows + (mapcar #'string-downcase field-names)))) ((1 10 "Park Place" "Leningrad" 123)) ("addressid" "street_number" "street_name" "city_field" "zip")) (deftest :fdml/select/16 - (clsql:select [emplid] :from [employee] :where [= 1 [emplid]] - :field-names nil) + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] :where [= 1 [emplid]] + :field-names nil)) ((1))) (deftest :fdml/select/17 - (clsql:select [emplid] [last-name] :from [employee] :where [= 1 [emplid]] - :field-names nil) + (with-dataset *ds-employees* + (clsql:select [emplid] [last-name] :from [employee] :where [= 1 [emplid]] + :field-names nil)) ((1 "Lenin"))) (deftest :fdml/select/18 - (clsql:select [emplid :string] [last-name] :from [employee] :where [= 1 [emplid]] - :field-names nil) + (with-dataset *ds-employees* + (clsql:select [emplid :string] [last-name] :from [employee] :where [= 1 [emplid]] + :field-names nil)) (("1" "Lenin"))) (deftest :fdml/select/19 - (clsql:select [emplid] :from [employee] :order-by [emplid] - :where [between [* [emplid] 10] [* 5 10] [* 10 10]] - :field-names nil :result-types nil :flatp t) - ("5" "6" "7" "8" "9" "10")) + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] :order-by [emplid] + :where [between [* [emplid] 10] [* 5 10] [* 10 10]] + :field-names nil :result-types nil :flatp t)) + ("5" "6" "7" "8" "9" "10")) (deftest :fdml/select/20 - (clsql:select [emplid] :from [employee] :order-by [emplid] - :where [not [between [* [emplid] 10] [* 5 10] [* 10 10]]] - :field-names nil :result-types nil :flatp t) - ("1" "2" "3" "4")) + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] :order-by [emplid] + :where [not [between [* [emplid] 10] [* 5 10] [* 10 10]]] + :field-names nil :result-types nil :flatp t)) + ("1" "2" "3" "4")) (deftest :fdml/select/21 - (clsql:select [substring [first-name] 1 4] :from [employee] - :flatp t :order-by [emplid] :field-names nil) - ("Vlad" "Jose" "Leon" "Niki" "Leon" "Yuri" "Kons" "Mikh" "Bori" "Vlad")) + (with-dataset *ds-employees* + (clsql:select [substring [first-name] 1 4] :from [employee] + :flatp t :order-by [emplid] :field-names nil)) + ("Vlad" "Jose" "Leon" "Niki" "Leon" "Yuri" "Kons" "Mikh" "Bori" "Vlad")) (deftest :fdml/select/22 - (case *test-database-underlying-type* - (:mssql (clsql:select [+ [first-name] " " [last-name]] :from [employee] - :flatp t :order-by [emplid] :field-names nil)) - (t (clsql:select [|| [first-name] " " [last-name]] :from [employee] - :flatp t :order-by [emplid] :field-names nil))) - ("Vladimir Lenin" "Josef Stalin" "Leon Trotsky" "Nikita Kruschev" - "Leonid Brezhnev" "Yuri Andropov" "Konstantin Chernenko" "Mikhail Gorbachev" - "Boris Yeltsin" "Vladimir Putin")) + (with-dataset *ds-employees* + (case *test-database-underlying-type* + (:mssql (clsql:select [+ [first-name] " " [last-name]] :from [employee] + :flatp t :order-by [emplid] :field-names nil)) + (t (clsql:select [|| [first-name] " " [last-name]] :from [employee] + :flatp t :order-by [emplid] :field-names nil)))) + ("Vladimir Lenin" "Josef Stalin" "Leon Trotsky" "Nikita Kruschev" + "Leonid Brezhnev" "Yuri Andropov" "Konstantin Chernenko" "Mikhail Gorbachev" + "Boris Yeltsin" "Vladimir Putin")) (deftest :fdml/select/23 - (clsql:select [emplid] :from [employee] :where [in [emplid] '(1 2 3 4)] - :flatp t :order-by [emplid] :field-names nil - :result-types nil) - ("1" "2" "3" "4")) + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] :where [in [emplid] '(1 2 3 4)] + :flatp t :order-by [emplid] :field-names nil + :result-types nil)) + ("1" "2" "3" "4")) (deftest :fdml/select/24 - (clsql:select [distinct [first-name]] :from [employee] :flatp t - :order-by [first-name] :field-names nil :result-types nil) - ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" - "Yuri")) + (with-dataset *ds-employees* + (clsql:select [distinct [first-name]] :from [employee] :flatp t + :order-by [first-name] :field-names nil :result-types nil)) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" + "Yuri")) (deftest :fdml/select/25 - (clsql:select [first-name] :from (clsql-sys:convert-to-db-default-case "employee" *default-database*) - :flatp t :distinct t - :field-names nil - :result-types nil - :order-by [first-name]) - ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" - "Yuri")) + (with-dataset *ds-employees* + (clsql:select [first-name] :from (clsql-sys:convert-to-db-default-case "employee" *default-database*) + :flatp t :distinct t + :field-names nil + :result-types nil + :order-by [first-name])) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladimir" + "Yuri")) (deftest :fdml/select/26 - (clsql:select ["table" first-name] ["table" last-name] - :from '([employee "table"] [employee "join"]) - :where [and [= ["table" first-name] - ["join" first-name]] - [not [= ["table" emplid] - ["join" emplid]]]] - :order-by '(["table" last-name]) - :result-types nil :field-names nil) - (("Vladimir" "Lenin") ("Vladimir" "Putin"))) + (with-dataset *ds-employees* + (clsql:select ["table" first-name] ["table" last-name] + :from '([employee "table"] [employee "join"]) + :where [and [= ["table" first-name] + ["join" first-name]] + [not [= ["table" emplid] + ["join" emplid]]]] + :order-by '(["table" last-name]) + :result-types nil :field-names nil)) + (("Vladimir" "Lenin") ("Vladimir" "Putin"))) (deftest :fdml/select/27 - (mapcar - (lambda (f) (truncate (read-from-string f))) - (clsql:select [coalesce [managerid] 10] :from [employee] :order-by [emplid] - :field-names nil :result-types nil :flatp t)) + (with-dataset *ds-employees* + (mapcar + (lambda (f) (truncate (read-from-string f))) + (clsql:select [coalesce [managerid] 10] :from [employee] :order-by [emplid] + :field-names nil :result-types nil :flatp t))) (10 1 1 1 1 1 1 1 1 1)) (deftest :fdml/select/28 - (mapcar - (lambda (f) (truncate (read-from-string (car f)))) - (loop for column in `([*] [emplid]) collect - (clsql:select [count column] :from [employee] - :flatp t :result-types nil :field-names nil))) - (10 10)) + (with-dataset *ds-employees* + (mapcar + (lambda (f) (truncate (read-from-string (car f)))) + (loop for column in `([*] [emplid]) collect + (clsql:select [count column] :from [employee] + :flatp t :result-types nil :field-names nil)))) + (10 10)) (deftest :fdml/select/29 - (clsql:select [first-name] [last-name] :from [employee] - :result-types nil :field-names nil - :order-by '(([first-name] :asc) ([last-name] :desc))) - (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") - ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") - ("Nikita" "Kruschev") ("Vladimir" "Putin") ("Vladimir" "Lenin") - ("Yuri" "Andropov"))) + (with-dataset *ds-employees* + (clsql:select [first-name] [last-name] :from [employee] + :result-types nil :field-names nil + :order-by '(([first-name] :asc) ([last-name] :desc)))) + (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") + ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") + ("Nikita" "Kruschev") ("Vladimir" "Putin") ("Vladimir" "Lenin") + ("Yuri" "Andropov"))) (deftest :fdml/select/30 - (clsql:select [first-name] [last-name] :from [employee] - :result-types nil :field-names nil - :order-by '(([first-name] :asc) ([last-name] :asc))) - (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") - ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") - ("Nikita" "Kruschev") ("Vladimir" "Lenin") ("Vladimir" "Putin") - ("Yuri" "Andropov"))) + (with-dataset *ds-employees* + (clsql:select [first-name] [last-name] :from [employee] + :result-types nil :field-names nil + :order-by '(([first-name] :asc) ([last-name] :asc)))) + (("Boris" "Yeltsin") ("Josef" "Stalin") ("Konstantin" "Chernenko") + ("Leon" "Trotsky") ("Leonid" "Brezhnev") ("Mikhail" "Gorbachev") + ("Nikita" "Kruschev") ("Vladimir" "Lenin") ("Vladimir" "Putin") + ("Yuri" "Andropov"))) (deftest :fdml/select/31 - (clsql:select [last-name] :from [employee] - :set-operation [union [select [first-name] :from [employee] - :order-by [last-name]]] - :flatp t - :result-types nil - :field-names nil) - ("Andropov" "Boris" "Brezhnev" "Chernenko" "Gorbachev" "Josef" "Konstantin" - "Kruschev" "Lenin" "Leon" "Leonid" "Mikhail" "Nikita" "Putin" "Stalin" - "Trotsky" "Vladimir" "Yeltsin" "Yuri")) + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :set-operation [union [select [first-name] :from [employee] + :order-by [last-name]]] + :flatp t + :result-types nil + :field-names nil)) + ("Andropov" "Boris" "Brezhnev" "Chernenko" "Gorbachev" "Josef" "Konstantin" + "Kruschev" "Lenin" "Leon" "Leonid" "Mikhail" "Nikita" "Putin" "Stalin" + "Trotsky" "Vladimir" "Yeltsin" "Yuri")) (deftest :fdml/select/32 - (clsql:select [emplid] :from [employee] - :where [= [emplid] [any [select [companyid] :from [company]]]] - :flatp t :result-types nil :field-names nil) + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] + :where [= [emplid] [any [select [companyid] :from [company]]]] + :flatp t :result-types nil :field-names nil)) ("1")) (deftest :fdml/select/33 - (clsql:select [last-name] :from [employee] - :where [> [emplid] [all [select [groupid] :from [employee]]]] - :order-by [last-name] - :flatp t :result-types nil :field-names nil) -("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" - "Trotsky" "Yeltsin")) + (with-dataset *ds-employees* + (clsql:select [last-name] :from [employee] + :where [> [emplid] [all [select [groupid] :from [employee]]]] + :order-by [last-name] + :flatp t :result-types nil :field-names nil)) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" + "Trotsky" "Yeltsin")) (deftest :fdml/select/34 - (loop for x from 1 below 5 - collect - (car - (clsql:select [last-name] :from [employee] - :where [= [emplid] x] - :flatp t :result-types nil :field-names nil))) + (with-dataset *ds-employees* + (loop for x from 1 below 5 + collect + (car + (clsql:select [last-name] :from [employee] + :where [= [emplid] x] + :flatp t :result-types nil :field-names nil)))) ("Lenin" "Stalin" "Trotsky" "Kruschev")) ;; test escaping of single quotes (deftest :fdml/select/35 - (clsql:select "What's up doc?" :from [employee] :flatp t :field-names nil) - ("What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" - "What's up doc?" "What's up doc?" "What's up doc?" "What's up doc?" - "What's up doc?" "What's up doc?")) + (with-dataset *ds-fddl* + (first (clsql:select "What's up doc?" :from [alpha] :flatp t :field-names nil))) + "What's up doc?") ;; test proper treatment of backslash (depending on backend) (deftest :fdml/select/36 - (clsql:select "foo\\bar\\baz" :from [employee] :flatp t :field-names nil) - ("foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" - "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" "foo\\bar\\baz" - "foo\\bar\\baz" "foo\\bar\\baz")) + (with-dataset *ds-fddl* + (first (clsql:select "foo\\bar\\baz" :from [alpha] :flatp t :field-names nil))) + "foo\\bar\\baz") (deftest :fdml/select/37 - (clsql:select [emplid] :from [employee] - :order-by [emplid] - :limit 5 - :field-names nil - :flatp t) + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] + :order-by [emplid] + :limit 5 + :field-names nil + :flatp t)) (1 2 3 4 5)) (deftest :fdml/select/38 - (clsql:select [emplid] :from [employee] - :order-by [emplid] - :limit 5 - :offset 3 - :field-names nil - :flatp t) + (with-dataset *ds-employees* + (clsql:select [emplid] :from [employee] + :order-by [emplid] + :limit 5 + :offset 3 + :field-names nil + :flatp t)) (4 5 6 7 8)) (deftest :fdml/do-query/1 - (let ((result '())) - (clsql:do-query ((name) [select [last-name] :from [employee] - :order-by [last-name]]) - (push name result)) - result) - ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" - "Chernenko" "Brezhnev" "Andropov")) + (with-dataset *ds-employees* + (let ((result '())) + (clsql:do-query ((name) [select [last-name] :from [employee] + :order-by [last-name]]) + (push name result)) + result)) + ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" + "Chernenko" "Brezhnev" "Andropov")) (deftest :fdml/map-query/1 - (clsql:map-query 'list #'identity - [select [last-name] :from [employee] :flatp t - :order-by [last-name]]) + (with-dataset *ds-employees* + (clsql:map-query 'list #'identity + [select [last-name] :from [employee] :flatp t + :order-by [last-name]])) ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) + "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/map-query/2 - (clsql:map-query 'vector #'identity - [select [last-name] :from [employee] :flatp t - :order-by [last-name]]) + (with-dataset *ds-employees* + (clsql:map-query 'vector #'identity + [select [last-name] :from [employee] :flatp t + :order-by [last-name]])) #("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" "Stalin" "Trotsky" "Yeltsin")) (deftest :fdml/map-query/3 - (clsql:map-query 'list #'identity - [select [last-name] :from [employee] :order-by [last-name]]) - (("Andropov") ("Brezhnev") ("Chernenko") ("Gorbachev") ("Kruschev") ("Lenin") - ("Putin") ("Stalin") ("Trotsky") ("Yeltsin"))) + (with-dataset *ds-employees* + (clsql:map-query 'list #'identity + [select [last-name] :from [employee] :order-by [last-name]])) + (("Andropov") ("Brezhnev") ("Chernenko") ("Gorbachev") ("Kruschev") ("Lenin") + ("Putin") ("Stalin") ("Trotsky") ("Yeltsin"))) (deftest :fdml/map-query/4 - (clsql:map-query 'list #'identity - [select [first-name] [last-name] :from [employee] - :order-by [last-name]]) - (("Yuri" "Andropov") ("Leonid" "Brezhnev") ("Konstantin" "Chernenko") - ("Mikhail" "Gorbachev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") - ("Vladimir" "Putin") ("Josef" "Stalin") ("Leon" "Trotsky") - ("Boris" "Yeltsin"))) + (with-dataset *ds-employees* + (clsql:map-query 'list #'identity + [select [first-name] [last-name] :from [employee] + :order-by [last-name]])) + (("Yuri" "Andropov") ("Leonid" "Brezhnev") ("Konstantin" "Chernenko") + ("Mikhail" "Gorbachev") ("Nikita" "Kruschev") ("Vladimir" "Lenin") + ("Vladimir" "Putin") ("Josef" "Stalin") ("Leon" "Trotsky") + ("Boris" "Yeltsin"))) (deftest :fdml/loop/1 - (loop for (forename surname) - being each tuple in - [select [first-name] [last-name] :from [employee] :order-by [last-name]] - collect (concatenate 'string forename " " surname)) + (with-dataset *ds-employees* + (loop for (forename surname) + being each tuple in + [select [first-name] [last-name] :from [employee] :order-by [last-name]] + collect (concatenate 'string forename " " surname))) ("Yuri Andropov" "Leonid Brezhnev" "Konstantin Chernenko" "Mikhail Gorbachev" - "Nikita Kruschev" "Vladimir Lenin" "Vladimir Putin" + "Nikita Kruschev" "Vladimir Lenin" "Vladimir Putin" "Josef Stalin" "Leon Trotsky" "Boris Yeltsin")) (deftest :fdml/loop/2 - (loop for (addressid) - being each tuple in - [select [addressid] :from [addr] :order-by [addressid]] - collect addressid) + (with-dataset *ds-employees* + (loop for (addressid) + being each tuple in + [select [addressid] :from [addr] :order-by [addressid]] + collect addressid)) (1 2)) (deftest :fdml/loop/3 - (loop for addressid - being each tuple in - [select [addressid] :from [addr] :order-by [addressid]] - collect addressid) + (with-dataset *ds-employees* + (loop for addressid + being each tuple in + [select [addressid] :from [addr] :order-by [addressid]] + collect addressid)) (1 2)) +;; inserts a record using all values only and then deletes it +(deftest :fdml/insert/1 + (with-dataset *ds-employees* + (let ((now (get-universal-time))) + (clsql:insert-records :into [employee] + :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1 1.85 t ,(clsql:utime->time now) ,now)) + (values + (clsql:select [first-name] [last-name] [email] + :from [employee] :where [= [emplid] 11]) + (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) + (clsql:select [*] :from [employee] :where [= [emplid] 11]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a record using attributes and values and then deletes it +(deftest :fdml/insert/2 + (with-dataset *ds-employees* + (progn + (clsql:insert-records :into [employee] + :attributes '(emplid groupid first_name last_name + email ecompanyid managerid) + :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1)) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]) + (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) + (clsql:select [*] :from [employee] :where [= [emplid] 11]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a record using av-pairs and then deletes it +(deftest :fdml/insert/3 + (with-dataset *ds-employees* + (progn + (clsql:insert-records :into [employee] + :av-pairs'((emplid 11) (groupid 1) + (first_name "Yuri") + (last_name "Gagarin") + (email "gagarin@soviet.org") + (ecompanyid 1) (managerid 1))) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]) + (progn (clsql:delete-records :from [employee] :where [= [emplid] 11]) + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a records using a query from another table +(deftest :fdml/insert/4 + (with-dataset *ds-employees* + (progn + (clsql:create-table [employee2] '(([forename] string) + ([surname] string) + ([email] string))) + (clsql:insert-records :into [employee2] + :query [select [first-name] [last-name] [email] + :from [employee]] + :attributes '(forename surname email)) + (prog1 + (equal (clsql:select [*] :from [employee2]) + (clsql:select [first-name] [last-name] [email] + :from [employee])) + (clsql:drop-table [employee2] :if-does-not-exist :ignore)))) + t) + +;; updates a record using attributes and values and then deletes it +(deftest :fdml/update/1 + (with-dataset *ds-employees* + (progn + (clsql:update-records [employee] + :attributes '(first_name last_name email) + :values '("Yuri" "Gagarin" "gagarin@soviet.org") + :where [= [emplid] 1]) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]) + (progn + (clsql:update-records [employee] + :av-pairs'((first_name "Vladimir") + (last_name "Lenin") + (email "lenin@soviet.org")) + :where [= [emplid] 1]) + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) + (("Vladimir" "Lenin" "lenin@soviet.org"))) + +;; updates a record using av-pairs and then deletes it +(deftest :fdml/update/2 + (with-dataset *ds-employees* + (progn + (clsql:update-records [employee] + :av-pairs'((first_name "Yuri") + (last_name "Gagarin") + (email "gagarin@soviet.org")) + :where [= [emplid] 1]) + (values + (clsql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]) + (progn + (clsql:update-records [employee] + :av-pairs'((first_name "Vladimir") + (last_name "Lenin") + (email "lenin@soviet.org")) + :where [= [emplid] 1]) + (clsql:select [first-name] [last-name] [email] + :from [employee] :where [= [emplid] 1]))))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) + (("Vladimir" "Lenin" "lenin@soviet.org"))) + + + ;; starts a transaction deletes a record and then rolls back the deletion (deftest :fdml/transaction/1 - (let ((results '())) - ;; test if we are in a transaction - (push (clsql:in-transaction-p) results) - ;;start a transaction - (clsql:start-transaction) - ;; test if we are in a transaction - (push (clsql:in-transaction-p) results) - ;;Putin has got to go - (clsql:delete-records :from [employee] :where [= [last-name] "Putin"]) - ;;Should be nil - (push - (clsql:select [*] :from [employee] :where [= [last-name] "Putin"]) - results) - ;;Oh no, he's still there - (clsql:rollback) - ;; test that we are out of the transaction - (push (clsql:in-transaction-p) results) - ;; Check that we got him back alright - (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] - :flatp t) - results) - (apply #'values (nreverse results))) + (with-dataset *ds-employees* + (let ((results '())) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;start a transaction + (clsql:start-transaction) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;Putin has got to go + (clsql:delete-records :from [employee] :where [= [last-name] "Putin"]) + ;;Should be nil + (push + (clsql:select [*] :from [employee] :where [= [last-name] "Putin"]) + results) + ;;Oh no, he's still there + (clsql:rollback) + ;; test that we are out of the transaction + (push (clsql:in-transaction-p) results) + ;; Check that we got him back alright + (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] + :flatp t) + results) + (apply #'values (nreverse results)))) nil t nil nil ("putin@soviet.org")) ;; starts a transaction, updates a record and then rolls back the update (deftest :fdml/transaction/2 - (let ((results '())) - ;; test if we are in a transaction - (push (clsql:in-transaction-p) results) - ;;start a transaction - (clsql:start-transaction) - ;; test if we are in a transaction - (push (clsql:in-transaction-p) results) - ;;Putin has got to go - (clsql:update-records [employee] - :av-pairs '((email "putin-nospam@soviet.org")) - :where [= [last-name] "Putin"]) - ;;Should be new value - (push (clsql:select [email] :from [employee] - :where [= [last-name] "Putin"] - :flatp t) - results) - ;;Oh no, he's still there - (clsql:rollback) - ;; test that we are out of the transaction - (push (clsql:in-transaction-p) results) - ;; Check that we got him back alright - (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] - :flatp t) - results) - (apply #'values (nreverse results))) + (with-dataset *ds-employees* + (let ((results '())) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;start a transaction + (clsql:start-transaction) + ;; test if we are in a transaction + (push (clsql:in-transaction-p) results) + ;;Putin has got to go + (clsql:update-records [employee] + :av-pairs '((email "putin-nospam@soviet.org")) + :where [= [last-name] "Putin"]) + ;;Should be new value + (push (clsql:select [email] :from [employee] + :where [= [last-name] "Putin"] + :flatp t) + results) + ;;Oh no, he's still there + (clsql:rollback) + ;; test that we are out of the transaction + (push (clsql:in-transaction-p) results) + ;; Check that we got him back alright + (push (clsql:select [email] :from [employee] :where [= [last-name] "Putin"] + :flatp t) + results) + (apply #'values (nreverse results)))) nil t ("putin-nospam@soviet.org") nil ("putin@soviet.org")) ;; runs an update within a transaction and checks it is committed (deftest :fdml/transaction/3 - (let ((results '())) - ;; check status - (push (clsql:in-transaction-p) results) - ;; update records - (push - (clsql:with-transaction () - (clsql:update-records [employee] - :av-pairs '((email "lenin-nospam@soviet.org")) - :where [= [emplid] 1])) - results) - ;; check status - (push (clsql:in-transaction-p) results) - ;; check that was committed - (push (clsql:select [email] :from [employee] :where [= [emplid] 1] - :flatp t) - results) - ;; undo the changes - (push - (clsql:with-transaction () - (clsql:update-records [employee] - :av-pairs '((email "lenin@soviet.org")) - :where [= [emplid] 1])) - results) - ;; and check status - (push (clsql:in-transaction-p) results) - ;; check that was committed - (push (clsql:select [email] :from [employee] :where [= [emplid] 1] - :flatp t) - results) - (apply #'values (nreverse results))) + (with-dataset *ds-employees* + (let ((results '())) + ;; check status + (push (clsql:in-transaction-p) results) + ;; update records + (push + (clsql:with-transaction () + (clsql:update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) + results) + ;; check status + (push (clsql:in-transaction-p) results) + ;; check that was committed + (push (clsql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + ;; undo the changes + (push + (clsql:with-transaction () + (clsql:update-records [employee] + :av-pairs '((email "lenin@soviet.org")) + :where [= [emplid] 1])) + results) + ;; and check status + (push (clsql:in-transaction-p) results) + ;; check that was committed + (push (clsql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + (apply #'values (nreverse results)))) nil nil nil ("lenin-nospam@soviet.org") nil nil ("lenin@soviet.org")) ;; runs a valid update and an invalid one within a transaction and checks ;; that the valid update is rolled back when the invalid one fails. (deftest :fdml/transaction/4 - (let ((results '())) - ;; check status - (push (clsql:in-transaction-p) results) - (handler-case - (clsql:with-transaction () - ;; valid update - (clsql:update-records [employee] - :av-pairs '((email "lenin-nospam@soviet.org")) - :where [= [emplid] 1]) - ;; invalid update which generates an error - (clsql:update-records [employee] - :av-pairs - '((emale "lenin-nospam@soviet.org")) - :where [= [emplid] 1])) - (clsql:sql-database-error () - (progn - ;; check status - (push (clsql:in-transaction-p) results) - ;; and check nothing done - (push (clsql:select [email] :from [employee] :where [= [emplid] 1] - :flatp t) - results) - (apply #'values (nreverse results)))))) + (with-dataset *ds-employees* + (let ((results '())) + ;; check status + (push (clsql:in-transaction-p) results) + (handler-case + (clsql:with-transaction () + ;; valid update + (clsql:update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + ;; invalid update which generates an error + (clsql:update-records [employee] + :av-pairs + '((emale "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) + (clsql:sql-database-error () + (progn + ;; check status + (push (clsql:in-transaction-p) results) + ;; and check nothing done + (push (clsql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + (apply #'values (nreverse results))))))) nil nil ("lenin@soviet.org")) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 3307198..110fbdc 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -34,201 +34,6 @@ (defvar *test-connection-spec* nil) (defvar *test-connection-db-type* nil) -(defclass thing () - ((extraterrestrial :initform nil :initarg :extraterrestrial))) - -(def-view-class person (thing) - ((height :db-kind :base :accessor height :type float - :initarg :height) - (married :db-kind :base :accessor married :type boolean - :initarg :married) - (birthday :type clsql:wall-time :initarg :birthday) - (bd-utime :type clsql:universal-time :initarg :bd-utime) - (hobby :db-kind :virtual :initarg :hobby :initform nil))) - -(def-view-class employee (person) - ((emplid - :db-kind :key - :db-constraints (:not-null :unique) - :type integer - :initarg :emplid) - (groupid - :db-kind :key - :db-constraints :not-null - :type integer - :initarg :groupid) - (first-name - :accessor first-name - :type (varchar 30) - :initarg :first-name) - (last-name - :accessor last-name - :type (varchar 30) - :initarg :last-name) - (email - :accessor employee-email - :type (varchar 100) - :initarg :email) - (ecompanyid - :type integer - :initarg :companyid) - (company - :accessor employee-company - :db-kind :join - :db-info (:join-class company - :home-key ecompanyid - :foreign-key companyid - :set nil)) - (managerid - :type integer - :initarg :managerid) - (manager - :accessor employee-manager - :db-kind :join - :db-info (:join-class employee - :home-key managerid - :foreign-key emplid - :set nil)) - (addresses - :accessor employee-addresses - :db-kind :join - :db-info (:join-class employee-address - :home-key emplid - :foreign-key aemplid - :target-slot address - :set t))) - (:base-table employee)) - -(def-view-class company () - ((companyid - :db-kind :key - :db-constraints :not-null - :type integer - :initarg :companyid) - (groupid - :db-kind :key - :db-constraints :not-null - :type integer - :initarg :groupid) - (name - :type (varchar 100) - :initarg :name) - (presidentid - :type integer - :initarg :presidentid) - (president - :reader president - :db-kind :join - :db-info (:join-class employee - :home-key presidentid - :foreign-key emplid - :set nil)) - (employees - :reader company-employees - :db-kind :join - :db-info (:join-class employee - :home-key (companyid groupid) - :foreign-key (ecompanyid groupid) - :set t)))) - -(def-view-class address () - ((addressid - :db-kind :key - :db-constraints :not-null - :type integer - :initarg :addressid) - (street-number - :type integer - :initarg :street-number) - (street-name - :type (varchar 30) - :void-value "" - :initarg :street-name) - (city - :column "city_field" - :void-value "no city" - :type (varchar 30) - :initarg :city) - (postal-code - :column zip - :type integer - :void-value 0 - :initarg :postal-code)) - (:base-table addr)) - -;; many employees can reside at many addressess -(def-view-class employee-address () - ((aemplid :type integer :initarg :emplid) - (aaddressid :type integer :initarg :addressid) - (verified :type boolean :initarg :verified) - (address :db-kind :join - :db-info (:join-class address - :home-key aaddressid - :foreign-key addressid - :retrieval :immediate)) - (employee :db-kind :join - :db-info (:join-class employee - :home-key aemplid - :foreign-key emplid - :retrieval :immediate))) - (:base-table "ea_join")) - -(def-view-class deferred-employee-address () - ((aemplid :type integer :initarg :emplid) - (aaddressid :type integer :initarg :addressid) - (verified :type boolean :initarg :verified) - (address :db-kind :join - :db-info (:join-class address - :home-key aaddressid - :foreign-key addressid - :retrieval :deferred - :set nil))) - (:base-table "ea_join")) - -(def-view-class big () - ((i :type integer :initarg :i) - (bi :type bigint :initarg :bi))) - -;; classes for testing the normalisedp stuff -(def-view-class node () - ((node-id :accessor node-id :initarg :node-id - :type integer :db-kind :key - :db-constraints (:not-null :auto-increment)) - (title :accessor title :initarg :title :type (varchar 240)) - (createtime :accessor createtime :initarg :createtime :type wall-time - :db-constraints (:not-null) :initform (get-time)) - (modifiedtime :accessor modifiedtime :initarg :modifiedtime :type wall-time - :initform (make-time :year 1900 :month 1 :day 1)))) - -(def-view-class setting (node) - ((setting-id :accessor setting-id :initarg :setting-id - :type integer :db-kind :key :db-constraints (:not-null)) - (vars :accessor vars :initarg :vars :type (varchar 240))) - (:normalisedp t)) - -(def-view-class user (node) - ((user-id :accessor user-id :initarg :user-id - :type integer :db-kind :key :db-constraints (:not-null)) - (nick :accessor nick :initarg :nick :type (varchar 64))) - (:normalisedp t)) - -(def-view-class theme (setting) - ((theme-id :accessor theme-id :initarg :theme-id - :type integer :db-kind :key :db-constraints (:not-null)) - (doc :accessor doc :initarg :doc :type (varchar 240))) - (:normalisedp t)) - -;; A class that uses only a superclass db table -(def-view-class location (node) - () - (:base-table node) - (:normalisedp t)) - -(def-view-class subloc (location) - ((subloc-id :accessor subloc-id :initarg :subloc-id - :type integer :db-kind :key :db-constraints (:not-null)) - (loc :accessor loc :initarg :loc :type (varchar 64))) - (:normalisedp t)) (defun test-connect-to-database (db-type spec) @@ -256,296 +61,6 @@ *default-database*) -(defparameter company1 nil) -(defparameter employee1 nil) -(defparameter employee2 nil) -(defparameter employee3 nil) -(defparameter employee4 nil) -(defparameter employee5 nil) -(defparameter employee6 nil) -(defparameter employee7 nil) -(defparameter employee8 nil) -(defparameter employee9 nil) -(defparameter employee10 nil) -(defparameter address1 nil) -(defparameter address2 nil) -(defparameter employee-address1 nil) -(defparameter employee-address2 nil) -(defparameter employee-address3 nil) -(defparameter employee-address4 nil) -(defparameter employee-address5 nil) -(defparameter basenode nil) -(defparameter derivednode1 nil) -(defparameter derivednode2 nil) -(defparameter node nil) -(defparameter setting1 nil) -(defparameter setting2 nil) -(defparameter user1 nil) -(defparameter user2 nil) -(defparameter theme1 nil) -(defparameter theme2 nil) -(defparameter loc1 nil) -(defparameter loc2 nil) -(defparameter subloc1 nil) -(defparameter subloc2 nil) - - -(defun test-initialise-database () - (test-basic-initialize) -;; (start-sql-recording :type :both) - (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) - (clsql:create-view-from-class 'employee-address) - (clsql:create-view-from-class 'big) - (clsql:create-view-from-class 'node) - (clsql:create-view-from-class 'setting) - (clsql:create-view-from-class 'user) - (clsql:create-view-from-class 'theme) - (clsql:create-view-from-class 'location) - (clsql:create-view-from-class 'subloc)) - - (setq *test-start-utime* (get-universal-time)) - (let* ((*db-auto-sync* t) - (now-time (clsql:utime->time *test-start-utime*))) - (setf company1 (make-instance 'company - :presidentid 1 - :companyid 1 - :groupid 1 - :name "Widgets Inc.") - employee1 (make-instance 'employee - :emplid 1 - :groupid 1 - :married t - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Vladimir" - :last-name "Lenin" - :email "lenin@soviet.org" - :companyid 1) - employee2 (make-instance 'employee - :emplid 2 - :groupid 1 - :height (1+ (random 1.00)) - :married t - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Josef" - :last-name "Stalin" - :email "stalin@soviet.org" - :managerid 1 - :companyid 1) - employee3 (make-instance 'employee - :emplid 3 - :groupid 1 - :height (1+ (random 1.00)) - :married t - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Leon" - :last-name "Trotsky" - :email "trotsky@soviet.org" - :managerid 1 - :companyid 1) - employee4 (make-instance 'employee - :emplid 4 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Nikita" - :last-name "Kruschev" - :email "kruschev@soviet.org" - :managerid 1 - :companyid 1) - employee5 (make-instance 'employee - :emplid 5 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Leonid" - :last-name "Brezhnev" - :email "brezhnev@soviet.org" - :managerid 1 - :companyid 1) - employee6 (make-instance 'employee - :emplid 6 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Yuri" - :last-name "Andropov" - :email "andropov@soviet.org" - :managerid 1 - :companyid 1) - employee7 (make-instance 'employee - :emplid 7 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Konstantin" - :last-name "Chernenko" - :email "chernenko@soviet.org" - :managerid 1 - :companyid 1) - employee8 (make-instance 'employee - :emplid 8 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Mikhail" - :last-name "Gorbachev" - :email "gorbachev@soviet.org" - :managerid 1 - :companyid 1) - employee9 (make-instance 'employee - :emplid 9 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Boris" - :last-name "Yeltsin" - :email "yeltsin@soviet.org" - :managerid 1 - :companyid 1) - employee10 (make-instance 'employee - :emplid 10 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :bd-utime *test-start-utime* - :birthday now-time - :first-name "Vladimir" - :last-name "Putin" - :email "putin@soviet.org" - :managerid 1 - :companyid 1) - address1 (make-instance 'address - :addressid 1 - :street-number 10 - :street-name "Park Place" - :city "Leningrad" - :postal-code 123) - address2 (make-instance 'address - :addressid 2) - employee-address1 (make-instance 'employee-address - :emplid 1 - :addressid 1 - :verified t) - employee-address2 (make-instance 'employee-address - :emplid 2 - :addressid 2 - :verified t) - employee-address3 (make-instance 'employee-address - :emplid 3 - :addressid 1 - :verified nil) - employee-address4 (make-instance 'employee-address - :emplid 1 - :addressid 2 - :verified nil) - employee-address5 (make-instance 'employee-address - :emplid 3 - :addressid 2) - node (make-instance 'node - :title "Bare node") - setting1 (make-instance 'setting - :title "Setting1" - :vars "var 1") - setting2 (make-instance 'setting - :title "Setting2" - :vars "var 2") - user1 (make-instance 'user - :title "user-1" - :nick "first user") - user2 (make-instance 'user - :title "user-2" - :nick "second user") - theme1 (make-instance 'theme - :title "theme-1" - :vars "empty" - :doc "first theme") - theme2 (make-instance 'theme - :title "theme-2" - :doc "second theme") - loc1 (make-instance 'location - :title "location-1") - loc2 (make-instance 'location - :title "location-2") - subloc1 (make-instance 'subloc - :title "subloc-1" - :loc "a subloc") - subloc2 (make-instance 'subloc - :title "subloc-2" - :loc "second subloc")) - - - (let ((max (expt 2 60))) - (dotimes (i 555) - (make-instance 'big :i (1+ i) :bi (truncate max (1+ i)))))) - - ;; sleep to ensure birthdays are no longer at current time - (sleep 1) - - #|| - ;; Lenin manages everyone - (clsql:add-to-relation employee2 'manager employee1) - (clsql:add-to-relation employee3 'manager employee1) - (clsql:add-to-relation employee4 'manager employee1) - (clsql:add-to-relation employee5 'manager employee1) - (clsql:add-to-relation employee6 'manager employee1) - (clsql:add-to-relation employee7 'manager employee1) - (clsql:add-to-relation employee8 'manager employee1) - (clsql:add-to-relation employee9 'manager employee1) - (clsql:add-to-relation employee10 'manager employee1) - ;; Everyone works for Widgets Inc. - (clsql:add-to-relation company1 'employees employee1) - (clsql:add-to-relation company1 'employees employee2) - (clsql:add-to-relation company1 'employees employee3) - (clsql:add-to-relation company1 'employees employee4) - (clsql:add-to-relation company1 'employees employee5) - (clsql:add-to-relation company1 'employees employee6) - (clsql:add-to-relation company1 'employees employee7) - (clsql:add-to-relation company1 'employees employee8) - (clsql:add-to-relation company1 'employees employee9) - (clsql:add-to-relation company1 'employees employee10) - ;; Lenin is president of Widgets Inc. - (clsql:add-to-relation company1 'president employee1) - ||# - - ;; store these instances - #|| - (clsql:update-records-from-instance employee1) - (clsql:update-records-from-instance employee2) - (clsql:update-records-from-instance employee3) - (clsql:update-records-from-instance employee4) - (clsql:update-records-from-instance employee5) - (clsql:update-records-from-instance employee6) - (clsql:update-records-from-instance employee7) - (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 address1) - (clsql:update-records-from-instance address2) - ||# - ) (defvar *error-count* 0) (defvar *error-list* nil) @@ -625,7 +140,7 @@ (write-report-banner "Test Suite" db-type *report-stream*) - (test-initialise-database) +; (test-initialise-database) (regression-test:rem-all-tests) (dolist (test-form test-forms) @@ -728,6 +243,20 @@ '(:postgresql :mysql :sqlite3))) (clsql-sys:in test :fdml/select/37 :fdml/select/38)) (push (cons test "LIMIT keyword not supported in SELECT") skip-tests)) + ((and (not (clsql-sys:db-type-has-auto-increment? db-underlying-type)) + (clsql-sys:in test :oodml/select/12 :oodml/select/13 :oodml/select/14 + :oodml/select/15 :oodml/select/16 :oodml/select/17 + :oodml/select/18 :oodml/select/19 :oodml/select/20 + :oodml/select/21 :oodml/select/22 + :oodml/update-records/4 :oodml/update-records/4-slots + :oodml/update-records/5 :oodml/update-records/5-slots + :oodml/update-records/6 :oodml/update-records/7 + :oodml/update-records/8 :oodml/update-records/9 + :oodml/update-records/9-slots :oodml/update-instance/3 + :oodml/update-instance/4 :oodml/update-instance/5 + :oodml/update-instance/6 :oodml/update-instance/7 + :oodml/db-auto-sync/3 :oodml/db-auto-sync/4)) + (push (cons test ":auto-increment not by backend.") skip-tests)) (t (push test-form test-forms))))) (values (nreverse test-forms) (nreverse skip-tests)))) @@ -737,7 +266,7 @@ (when *default-database* (disconnect :database *default-database*)) (test-connect-to-database type (nth position (db-type-spec type (read-specs)))) - (test-initialise-database) + ;(test-initialise-database) *default-database*) (defun rl () diff --git a/tests/test-ooddl.lisp b/tests/test-ooddl.lisp index d7a1933..24a9750 100644 --- a/tests/test-ooddl.lisp +++ b/tests/test-ooddl.lisp @@ -20,6 +20,21 @@ #.(clsql:locally-enable-sql-reader-syntax) + +(def-view-class big () + ((i :type integer :initarg :i) + (bi :type bigint :initarg :bi))) + +(def-dataset *ds-big* + (:setup (lambda () + (clsql-sys:create-view-from-class 'big) + (let ((max (expt 2 60))) + (dotimes (i 555) + (update-records-from-instance + (make-instance 'big :i (1+ i) :bi (truncate max (1+ i)))))))) + (:cleanup + (lambda () (clsql-sys:drop-view-from-class 'big)))) + (setq *rt-ooddl* '( @@ -73,57 +88,99 @@ ; nil t) (deftest :ooddl/join/1 - (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) - (company-employees company1)) + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) + (company-employees company1))) (1 1 1 1 1 1 1 1 1 1)) (deftest :ooddl/join/2 - (slot-value (president company1) 'last-name) + (with-dataset *ds-employees* + (slot-value (president company1) 'last-name)) "Lenin") (deftest :ooddl/join/3 - (slot-value (employee-manager employee2) 'last-name) + (with-dataset *ds-employees* + (slot-value (employee-manager employee2) 'last-name)) "Lenin") +(deftest :ooddl/big/1 + ;;tests that we can create-view-from-class with a bigint slot, + ;; and stick a value in there. + (progn (clsql-sys:create-view-from-class 'big) + (values + (clsql:table-exists-p [big] :owner *test-database-user*) + (progn + (clsql:drop-table [big] :if-does-not-exist :ignore) + (clsql:table-exists-p [big] :owner *test-database-user*))) + ) + t nil) + +(deftest :ooddl/big/2 + (with-dataset *ds-big* + (let ((rows (clsql:select [*] :from [big] :order-by [i] :field-names nil))) + (values + (length rows) + (do ((i 0 (1+ i)) + (max (expt 2 60)) + (rest rows (cdr rest))) + ((= i (length rows)) t) + (let ((index (1+ i)) + (int (first (car rest))) + (bigint (second (car rest)))) + (when (and (or (eq *test-database-type* :oracle) + (and (eq *test-database-type* :odbc) + (eq *test-database-underlying-type* :postgresql))) + (stringp bigint)) + (setf bigint (parse-integer bigint))) + (unless (and (eql int index) + (eql bigint (truncate max index))) + (return nil))))))) + 555 t) + (deftest :ooddl/time/1 - (let* ((now (clsql:get-time))) - (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) - (clsql:execute-command "set datestyle to 'iso'")) - (clsql:update-records [employee] :av-pairs `((birthday ,now)) - :where [= [emplid] 1]) - (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] - :flatp t)))) - (values - (slot-value dbobj 'last-name) - (clsql:time= (slot-value dbobj 'birthday) now)))) + (with-dataset *ds-employees* + (sleep 1) ;force birthdays into the past + (let* ((now (clsql:get-time))) + (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) + (clsql:execute-command "set datestyle to 'iso'")) + (clsql:update-records [employee] :av-pairs `((birthday ,now)) + :where [= [emplid] 1]) + (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] + :flatp t)))) + (values + (slot-value dbobj 'last-name) + (clsql:time= (slot-value dbobj 'birthday) now))))) "Lenin" t) (deftest :ooddl/time/2 - (let* ((now (clsql:get-time)) - (fail-index -1)) - (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) - (clsql:execute-command "set datestyle to 'iso'")) - (dotimes (x 40) - (clsql:update-records [employee] :av-pairs `((birthday ,now)) - :where [= [emplid] 1]) - (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] - :flatp t)))) - (unless (clsql:time= (slot-value dbobj 'birthday) now) - (setf fail-index x)) - (setf now (clsql:roll now :day (* 10 x))))) - fail-index) + (with-dataset *ds-employees* + (sleep 1) ;force birthdays into the past + (let* ((now (clsql:get-time)) + (fail-index -1)) + (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) + (clsql:execute-command "set datestyle to 'iso'")) + (dotimes (x 40) + (clsql:update-records [employee] :av-pairs `((birthday ,now)) + :where [= [emplid] 1]) + (let ((dbobj (car (clsql:select 'employee :where [= [birthday] now] + :flatp t)))) + (unless (clsql:time= (slot-value dbobj 'birthday) now) + (setf fail-index x)) + (setf now (clsql:roll now :day (* 10 x))))) + fail-index)) -1) (deftest :ooddl/time/3 - (progn - (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) - (clsql:execute-command "set datestyle to 'iso'")) - (let ((dbobj (car (clsql:select 'employee :where [= [emplid] 10] - :flatp t)))) - (list - (eql *test-start-utime* (slot-value dbobj 'bd-utime)) - (clsql:time= (slot-value dbobj 'birthday) - (clsql:utime->time (slot-value dbobj 'bd-utime)))))) + (with-dataset *ds-employees* + (progn + (when (member *test-database-underlying-type* '(:postgresql :postgresql-socket)) + (clsql:execute-command "set datestyle to 'iso'")) + (let ((dbobj (car (clsql:select 'employee :where [= [emplid] 10] + :flatp t)))) + (list + (eql *test-start-utime* (slot-value dbobj 'bd-utime)) + (clsql:time= (slot-value dbobj 'birthday) + (clsql:utime->time (slot-value dbobj 'bd-utime))))))) (t t)) )) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index 6dd7617..ca1b7f8 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -21,1205 +21,1091 @@ (setq *rt-oodml* '( - (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")) - - (deftest :oodml/select/2 - (mapcar #'(lambda (e) (slot-value e 'name)) - (clsql:select 'company :flatp t :caching nil)) - ("Widgets Inc.")) - - (deftest :oodml/select/3 - (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) - (clsql:select 'employee - :where [and [= [slot-value 'employee 'ecompanyid] - [slot-value 'company 'companyid]] - [= [slot-value 'company 'name] - "Widgets Inc."]] - :flatp t - :caching nil)) - (1 1 1 1 1 1 1 1 1 1)) - - (deftest :oodml/select/4 - (mapcar #'(lambda (e) - (concatenate 'string (slot-value e 'first-name) - " " - (slot-value e 'last-name))) - (clsql:select 'employee :where [= [slot-value 'employee 'first-name] - "Vladimir"] - :flatp t - :order-by [last-name] - :caching nil)) - ("Vladimir Lenin" "Vladimir Putin")) - - (deftest :oodml/select/5 - (length (clsql:select 'employee :where [married] :flatp t :caching nil)) - 3) - - (deftest :oodml/select/6 - (let ((a (caar (clsql:select 'address :where [= 1 [addressid]] :caching nil)))) - (values - (slot-value a 'street-number) - (slot-value a 'street-name) - (slot-value a 'city) - (slot-value a 'postal-code))) - 10 "Park Place" "Leningrad" 123) - - (deftest :oodml/select/7 - (let ((a (caar (clsql:select 'address :where [= 2 [addressid]] :caching nil)))) - (values - (slot-value a 'street-number) - (slot-value a 'street-name) - (slot-value a 'city) - (slot-value a 'postal-code))) - nil "" "no city" 0) - - (deftest :oodml/select/8 - (mapcar #'(lambda (e) (slot-value e 'married)) - (clsql:select 'employee :flatp t :order-by [emplid] :caching nil)) - (t t t nil nil nil nil nil nil nil)) - - (deftest :oodml/select/9 - (mapcar #'(lambda (pair) - (list - (typep (car pair) 'address) - (typep (second pair) 'employee-address) - (slot-value (car pair) 'addressid) - (slot-value (second pair) 'aaddressid) - (slot-value (second pair) 'aemplid))) - (employee-addresses employee1)) - ((t t 1 1 1) (t t 2 2 1))) - - (deftest :oodml/select/10 - (mapcar #'(lambda (pair) - (list - (typep (car pair) 'address) - (typep (second pair) 'employee-address) - (slot-value (car pair) 'addressid) - (slot-value (second pair) 'aaddressid) - (slot-value (second pair) 'aemplid))) - (employee-addresses employee2)) - ((t t 2 2 2))) - - (deftest :oodml/select/11 - (values (mapcar #'(lambda (x) (slot-value x 'emplid)) - (clsql:select 'employee :order-by '(([emplid] :asc)) - :flatp t)) - (mapcar #'(lambda (x) (slot-value x 'emplid)) - (clsql:select 'employee :order-by '(([emplid] :desc)) - :flatp t))) - (1 2 3 4 5 6 7 8 9 10) - (10 9 8 7 6 5 4 3 2 1)) - - ;; test retrieval of node, derived nodes etc - (deftest :oodml/select/12 - (length (clsql:select 'node :where [node-id] :flatp t :caching nil)) - 11) - - (deftest :oodml/select/13 - (let ((a (car (clsql:select 'node :where [= 1 [node-id]] :flatp t :caching nil)))) - (values - (slot-value a 'node-id) - (slot-value a 'title))) - 1 "Bare node") - - (deftest :oodml/select/14 - (length (clsql:select 'setting :where [setting-id] :flatp t :caching nil)) - 4) - - (deftest :oodml/select/15 - (let ((a (car (clsql:select 'setting :where [= 3 [setting-id]] :flatp t :caching nil)))) - (values - (slot-value a 'node-id) - (slot-value a 'setting-id) - (slot-value a 'title) - (slot-value a 'vars))) - 3 3 "Setting2" "var 2") - - (deftest :oodml/select/16 - (length (clsql:select 'user :where [user-id] :flatp t :caching nil)) - 2) - - (deftest :oodml/select/17 - (let ((a (car (clsql:select 'user :where [= 4 [user-id]] :flatp t :caching nil)))) - (values - (slot-value a 'node-id) - (slot-value a 'user-id) - (slot-value a 'title) - (slot-value a 'nick))) - 4 4 "user-1" "first user") - - (deftest :oodml/select/18 - (length (clsql:select 'theme :where [theme-id] :flatp t :caching nil)) - 2) - - (deftest :oodml/select/19 - (let ((a (car (clsql:select 'theme :where [= 6 [theme-id]] :flatp t :caching nil)))) - (slot-value a 'theme-id)) - 6) - - (deftest :oodml/select/20 - (let ((a (car (clsql:select 'theme :where [= 7 [theme-id]] :flatp t :caching nil)))) - (values - (slot-value a 'node-id) - (slot-value a 'theme-id) - (slot-value a 'title) - (slot-value a 'vars) - (slot-value a 'doc) - )) - 7 7 "theme-2" - nil "second theme") - - ;; Some tests to check weird subclassed nodes (node without own table, or subclassed of same) - (deftest :oodml/select/21 - (let ((a (car (clsql:select 'location :where [= [title] "location-1"] :flatp t :caching nil)))) - (values - (slot-value a 'node-id) - (slot-value a 'title))) - 8 "location-1") - - (deftest :oodml/select/22 - (let ((a (car (clsql:select 'subloc :where [subloc-id] :flatp t :caching nil)))) - (values - (slot-value a 'node-id) - (slot-value a 'subloc-id) - (slot-value a 'title) - (slot-value a 'loc))) - 10 10 "subloc-1" "a subloc") - - ;; test retrieval is deferred - (deftest :oodm/retrieval/1 - (every #'(lambda (e) (not (slot-boundp e 'company))) - (select 'employee :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/2 - (every #'(lambda (e) (not (slot-boundp e 'address))) - (select 'deferred-employee-address :flatp t :caching nil)) - t) - - ;; :retrieval :immediate should be boundp before accessed - (deftest :oodm/retrieval/3 - (every #'(lambda (ea) (slot-boundp ea 'address)) - (select 'employee-address :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/4 - (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) - (select 'employee-address :flatp t :caching nil)) - (t t t t t)) - - (deftest :oodm/retrieval/5 - (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) - (select 'deferred-employee-address :flatp t :caching nil)) - (t t t t t)) - - (deftest :oodm/retrieval/6 - (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) - (select 'employee-address :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/7 - (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) - (select 'deferred-employee-address :flatp t :caching nil)) - t) - - (deftest :oodm/retrieval/8 - (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) - (select 'employee-address :flatp t :order-by [aaddressid] :caching nil)) - (10 10 nil nil nil)) - - (deftest :oodm/retrieval/9 - (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) - (select 'deferred-employee-address :flatp t :order-by [aaddressid] :caching nil)) - (10 10 nil nil nil)) - - ;; tests update-records-from-instance - (deftest :oodml/update-records/1 - (values - (progn - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Dimitriy" - (slot-value employee1 'last-name) "Ivanovich" - (slot-value employee1 'email) "ivanovich@soviet.org") - (clsql:update-records-from-instance employee1) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Vladimir" - (slot-value employee1 'last-name) "Lenin" - (slot-value employee1 'email) "lenin@soviet.org") - (clsql:update-records-from-instance employee1) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))))) - "Vladimir Lenin: lenin@soviet.org" - "Dimitriy Ivanovich: ivanovich@soviet.org" - "Vladimir Lenin: lenin@soviet.org") - - ;; tests update-record-from-slot - (deftest :oodml/update-records/2 - (values - (employee-email - (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1] - :flatp t - :caching nil))) - (progn - (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") - (clsql:update-record-from-slot employee1 'email) - (employee-email - (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1] - :flatp t - :caching nil)))) - (progn - (setf (slot-value employee1 'email) "lenin@soviet.org") - (clsql:update-record-from-slot employee1 'email) - (employee-email - (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] 1] - :flatp t - :caching nil))))) - "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") - - ;; tests update-record-from-slots - (deftest :oodml/update-records/3 - (values - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))) - (progn - (setf (slot-value employee1 'first-name) "Dimitriy" - (slot-value employee1 'last-name) "Ivanovich" - (slot-value employee1 'email) "ivanovich@soviet.org") - (clsql:update-record-from-slots employee1 '(first-name last-name email)) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Vladimir" - (slot-value employee1 'last-name) "Lenin" - (slot-value employee1 'email) "lenin@soviet.org") - (clsql:update-record-from-slots employee1 '(first-name last-name email)) - (let ((lenin (car (clsql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil)))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))))) - "Vladimir Lenin: lenin@soviet.org" - "Dimitriy Ivanovich: ivanovich@soviet.org" - "Vladimir Lenin: lenin@soviet.org") - - (deftest :oodml/update-records/4 - (values - (progn - (let ((base (car (clsql:select 'node - :where [= [slot-value 'node 'node-id] - 1] - :flatp t - :caching nil)))) - (with-output-to-string (out) - (format out "~a ~a" - (slot-value base 'node-id) - (slot-value base 'title))))) - (progn - (let ((base (car (clsql:select 'node - :where [= [slot-value 'node 'node-id] - 1] - :flatp t - :caching nil)))) - (setf (slot-value base 'title) "Altered title") - (clsql:update-records-from-instance base) - (with-output-to-string (out) - (format out "~a ~a" - (slot-value base 'node-id) - (slot-value base 'title))))) - (progn - (let ((base (car (clsql:select 'node - :where [= [slot-value 'node 'node-id] - 1] - :flatp t - :caching nil)))) - (setf (slot-value base 'title) "Bare node") - (clsql:update-records-from-instance base) - (with-output-to-string (out) - (format out "~a ~a" - (slot-value base 'node-id) - (slot-value base 'title)))))) - "1 Bare node" - "1 Altered title" - "1 Bare node") - - (deftest :oodml/update-records/5 - (values - (progn - (let ((node (car (clsql:select 'setting - :where [= [slot-value 'setting 'setting-id] - 3] - :flatp t - :caching nil)))) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'setting-id) - (slot-value node 'title) - (slot-value node 'vars))))) - (progn - (let ((node (car (clsql:select 'setting - :where [= [slot-value 'setting 'setting-id] - 3] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "Altered title") - (setf (slot-value node 'vars) "Altered vars") - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'setting-id) - (slot-value node 'title) - (slot-value node 'vars))))) - (progn - (let ((node (car (clsql:select 'setting - :where [= [slot-value 'setting 'setting-id] - 3] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "Setting2") - (setf (slot-value node 'vars) "var 2") - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'setting-id) - (slot-value node 'title) - (slot-value node 'vars)))))) - "3 Setting2 var 2" - "3 Altered title Altered vars" - "3 Setting2 var 2") - - (deftest :oodml/update-records/6 - (values - (progn - (let ((node (car (clsql:select 'setting - :where [= [slot-value 'setting 'setting-id] - 7] - :flatp t - :caching nil)))) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'setting-id) - (slot-value node 'title) - (slot-value node 'vars))))) - (progn - (let ((node (car (clsql:select 'setting - :where [= [slot-value 'setting 'setting-id] - 7] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "Altered title") - (setf (slot-value node 'vars) "Altered vars") - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'setting-id) - (slot-value node 'title) - (slot-value node 'vars))))) - (progn - (let ((node (car (clsql:select 'setting - :where [= [slot-value 'setting 'setting-id] - 7] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "theme-2") - (setf (slot-value node 'vars) nil) - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'setting-id) - (slot-value node 'title) - (slot-value node 'vars)))))) - "7 theme-2 NIL" - "7 Altered title Altered vars" - "7 theme-2 NIL") - - (deftest :oodml/update-records/7 - (values - (progn - (let ((node (car (clsql:select 'user - :where [= [slot-value 'user 'user-id] - 5] - :flatp t - :caching nil)))) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'user-id) - (slot-value node 'title) - (slot-value node 'nick))))) - (progn - (let ((node (car (clsql:select 'user - :where [= [slot-value 'user 'user-id] - 5] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "Altered title") - (setf (slot-value node 'nick) "Altered nick") - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'user-id) - (slot-value node 'title) - (slot-value node 'nick))))) - (progn - (let ((node (car (clsql:select 'user - :where [= [slot-value 'user 'user-id] - 5] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "user-2") - (setf (slot-value node 'nick) "second user") - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'user-id) - (slot-value node 'title) - (slot-value node 'nick)))))) - "5 user-2 second user" - "5 Altered title Altered nick" - "5 user-2 second user") - - (deftest :oodml/update-records/8 - (values - (progn - (let ((node (car (clsql:select 'theme - :where [= [slot-value 'theme 'theme-id] - 6] - :flatp t - :caching nil)))) - (with-output-to-string (out) - (format out "~a ~a ~a ~a ~a ~a" - (slot-value node 'node-id) - (slot-value node 'setting-id) - (slot-value node 'theme-id) - (slot-value node 'title) - (slot-value node 'vars) - (slot-value node 'doc))))) - (progn - (let ((node (car (clsql:select 'setting - :where [= [slot-value 'setting 'setting-id] - 6] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "Altered title") - (setf (slot-value node 'vars) nil) - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value node 'setting-id) - (slot-value node 'title) - (slot-value node 'vars))))) - (progn - (let ((node (car (clsql:select 'theme - :where [= [slot-value 'theme 'theme-id] - 6] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "Altered title again") - (setf (slot-value node 'doc) "altered doc") - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a ~a ~a ~a" - (slot-value node 'node-id) - (slot-value node 'setting-id) - (slot-value node 'theme-id) - (slot-value node 'title) - (slot-value node 'vars) - (slot-value node 'doc))))) - (progn - (let ((node (car (clsql:select 'theme - :where [= [slot-value 'theme 'theme-id] - 6] - :flatp t - :caching nil)))) - (setf (slot-value node 'title) "theme-1") - (setf (slot-value node 'vars) "empty") - (setf (slot-value node 'doc) "first theme") - (clsql:update-records-from-instance node) - (with-output-to-string (out) - (format out "~a ~a ~a ~a ~a ~a" - (slot-value node 'node-id) - (slot-value node 'setting-id) - (slot-value node 'theme-id) - (slot-value node 'title) - (slot-value node 'vars) - (slot-value node 'doc)))))) - "6 6 6 theme-1 empty first theme" - "6 Altered title NIL" - "6 6 6 Altered title again NIL altered doc" - "6 6 6 theme-1 empty first theme") - - (deftest :oodml/update-records/9 - (values - (progn - (let ((sl (car (clsql:select 'subloc - :where [= [slot-value 'subloc 'subloc-id] - 10] - :flatp t - :caching nil)))) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value sl 'subloc-id) - (slot-value sl 'title) - (slot-value sl 'loc))))) - (progn - (let ((sl (car (clsql:select 'subloc - :where [= [slot-value 'subloc 'subloc-id] - 10] - :flatp t - :caching nil)))) - (setf (slot-value sl 'title) "Altered subloc title") - (setf (slot-value sl 'loc) "Altered loc") - (clsql:update-records-from-instance sl) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value sl 'subloc-id) - (slot-value sl 'title) - (slot-value sl 'loc))))) - (progn - (let ((sl (car (clsql:select 'subloc - :where [= [slot-value 'subloc 'subloc-id] - 10] - :flatp t - :caching nil)))) - (setf (slot-value sl 'title) "subloc-1") - (setf (slot-value sl 'loc) "a subloc") - (clsql:update-records-from-instance sl) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value sl 'subloc-id) - (slot-value sl 'title) - (slot-value sl 'loc)))))) - "10 subloc-1 a subloc" - "10 Altered subloc title Altered loc" - "10 subloc-1 a subloc") - - ;; tests update-instance-from-records - (deftest :oodml/update-instance/1 - (values - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email)) - (progn - (clsql:update-records [employee] - :av-pairs '(([first-name] "Ivan") - ([last-name] "Petrov") - ([email] "petrov@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-instance-from-records employee1) - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email))) - (progn - (clsql:update-records [employee] - :av-pairs '(([first-name] "Vladimir") - ([last-name] "Lenin") - ([email] "lenin@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-instance-from-records employee1) - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email)))) - "Vladimir Lenin: lenin@soviet.org" - "Ivan Petrov: petrov@soviet.org" - "Vladimir Lenin: lenin@soviet.org") - - ;; tests update-slot-from-record - (deftest :oodml/update-instance/2 - (values - (slot-value employee1 'email) - (progn - (clsql:update-records [employee] - :av-pairs '(([email] "lenin-nospam@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-slot-from-record employee1 'email) - (slot-value employee1 'email)) - (progn - (clsql:update-records [employee] - :av-pairs '(([email] "lenin@soviet.org")) - :where [= [emplid] 1]) - (clsql:update-slot-from-record employee1 'email) - (slot-value employee1 'email))) - "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") - - ;; tests normalisedp update-instance-from-records - (deftest :oodml/update-instance/3 - (values - (with-output-to-string (out) - (format out "~a ~a ~a ~a" - (slot-value theme2 'theme-id) - (slot-value theme2 'title) - (slot-value theme2 'vars) - (slot-value theme2 'doc))) - (progn - (clsql:update-records [node] :av-pairs '(([title] "Altered title")) - :where [= [node-id] 7]) - (clsql:update-records [setting] :av-pairs '(([vars] "Altered vars")) - :where [= [setting-id] 7]) - (clsql:update-records [theme] :av-pairs '(([doc] "Altered doc")) - :where [= [theme-id] 7]) - (clsql:update-instance-from-records theme2) - (with-output-to-string (out) - (format out "~a ~a ~a ~a" - (slot-value theme2 'theme-id) - (slot-value theme2 'title) - (slot-value theme2 'vars) - (slot-value theme2 'doc)))) - (progn - (clsql:update-records [node] :av-pairs '(([title] "theme-2")) - :where [= [node-id] 7]) - (clsql:update-records [setting] :av-pairs '(([vars] nil)) - :where [= [setting-id] 7]) - (clsql:update-records [theme] :av-pairs '(([doc] "second theme")) - :where [= [theme-id] 7]) - (clsql:update-instance-from-records theme2) - (with-output-to-string (out) - (format out "~a ~a ~a ~a" - (slot-value theme2 'theme-id) - (slot-value theme2 'title) - (slot-value theme2 'vars) - (slot-value theme2 'doc))))) - "7 theme-2 NIL second theme" - "7 Altered title Altered vars Altered doc" - "7 theme-2 NIL second theme") - - (deftest :oodml/update-instance/4 - (values - (progn - (setf loc2 (car (clsql:select 'location - :where [= [node-id] 9] - :flatp t :caching nil))) - (with-output-to-string (out) - (format out "~a ~a" - (slot-value loc2 'node-id) - (slot-value loc2 'title)))) - (progn - (clsql:update-records [node] :av-pairs '(([title] "Altered title")) - :where [= [node-id] 9]) - (clsql:update-instance-from-records loc2) - (with-output-to-string (out) - (format out "~a ~a" - (slot-value loc2 'node-id) - (slot-value loc2 'title)))) - (progn - (clsql:update-records [node] :av-pairs '(([title] "location-2")) - :where [= [node-id] 9]) - (clsql:update-instance-from-records loc2) - (with-output-to-string (out) - (format out "~a ~a" - (slot-value loc2 'node-id) - (slot-value loc2 'title))))) - "9 location-2" - "9 Altered title" - "9 location-2") - - (deftest :oodml/update-instance/5 - (values - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value subloc2 'subloc-id) - (slot-value subloc2 'title) - (slot-value subloc2 'loc))) - (progn - (clsql:update-records [node] :av-pairs '(([title] "Altered title")) - :where [= [node-id] 11]) - (clsql:update-records [subloc] :av-pairs '(([loc] "Altered loc")) - :where [= [subloc-id] 11]) - (clsql:update-instance-from-records subloc2) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value subloc2 'subloc-id) - (slot-value subloc2 'title) - (slot-value subloc2 'loc)))) - (progn - (clsql:update-records [node] :av-pairs '(([title] "subloc-2")) - :where [= [node-id] 11]) - (clsql:update-records [subloc] :av-pairs '(([loc] "second subloc")) - :where [= [subloc-id] 11]) - (clsql:update-instance-from-records subloc2) - (with-output-to-string (out) - (format out "~a ~a ~a" - (slot-value subloc2 'subloc-id) - (slot-value subloc2 'title) - (slot-value subloc2 'loc))))) - "11 subloc-2 second subloc" - "11 Altered title Altered loc" - "11 subloc-2 second subloc") - - ;; tests update-slot-from-record with normalisedp stuff - (deftest :oodml/update-instance/6 - (values - (slot-value theme1 'doc) - (slot-value theme1 'vars) - (progn - (clsql:update-records [theme] - :av-pairs '(([doc] "altered doc")) - :where [= [theme-id] 6]) - (clsql:update-slot-from-record theme1 'doc) - (slot-value theme1 'doc)) - (progn - (clsql:update-records [setting] - :av-pairs '(([vars] "altered vars")) - :where [= [setting-id] 6]) - (clsql:update-slot-from-record theme1 'vars) - (slot-value theme1 'vars)) - (progn - (clsql:update-records [theme] - :av-pairs '(([doc] "first theme")) - :where [= [theme-id] 6]) - (clsql:update-slot-from-record theme1 'doc) - (slot-value theme1 'doc)) - (progn - (clsql:update-records [setting] - :av-pairs '(([vars] "empty")) - :where [= [setting-id] 6]) - (clsql:update-slot-from-record theme1 'vars) - (slot-value theme1 'vars))) - "first theme" "empty" - "altered doc" "altered vars" - "first theme" "empty") - - (deftest :oodml/update-instance/7 - (values - (slot-value loc2 'title) - (slot-value subloc2 'loc) - (progn - (clsql:update-records [node] - :av-pairs '(([title] "altered title")) - :where [= [node-id] 9]) - (clsql:update-slot-from-record loc2 'title) - (slot-value loc2 'title)) - (progn - (clsql:update-records [subloc] - :av-pairs '(([loc] "altered loc")) - :where [= [subloc-id] 11]) - (clsql:update-slot-from-record subloc2 'loc) - (slot-value subloc2 'loc)) - (progn - (clsql:update-records [node] - :av-pairs '(([title] "location-2")) - :where [= [node-id] 9]) - (clsql:update-slot-from-record loc2 'title) - (slot-value loc2 'title)) - (progn - (clsql:update-records [subloc] - :av-pairs '(([loc] "second subloc")) - :where [= [subloc-id] 11]) - (clsql:update-slot-from-record subloc2 'loc) - (slot-value subloc2 'loc))) - "location-2" "second subloc" - "altered title" "altered loc" - "location-2" "second subloc") - - (deftest :oodml/do-query/1 - (let ((result '())) - (clsql:do-query ((e) [select 'employee :order-by [emplid]]) - (push (slot-value e 'last-name) result)) - result) - ("Putin" "Yeltsin" "Gorbachev" "Chernenko" "Andropov" "Brezhnev" "Kruschev" - "Trotsky" "Stalin" "Lenin")) - - (deftest :oodml/do-query/2 - (let ((result '())) - (clsql:do-query ((e c) [select 'employee 'company - :where [= [slot-value 'employee 'last-name] - "Lenin"]]) - (push (list (slot-value e 'last-name) (slot-value c 'name)) - result)) - result) - (("Lenin" "Widgets Inc."))) - - (deftest :oodml/map-query/1 - (clsql:map-query 'list #'last-name [select 'employee :order-by [emplid]]) - ("Lenin" "Stalin" "Trotsky" "Kruschev" "Brezhnev" "Andropov" "Chernenko" - "Gorbachev" "Yeltsin" "Putin")) - - (deftest :oodml/map-query/2 - (clsql:map-query 'list #'(lambda (e c) (list (slot-value e 'last-name) - (slot-value c 'name))) - [select 'employee 'company :where [= [slot-value 'employee 'last-name] - "Lenin"]]) - (("Lenin" "Widgets Inc."))) - - (deftest :oodml/iteration/3 - (loop for (e) being the records in - [select 'employee :where [< [emplid] 4] :order-by [emplid]] - collect (slot-value e 'last-name)) - ("Lenin" "Stalin" "Trotsky")) - - - (deftest :oodml/cache/1 - (progn - (setf (clsql-sys:record-caches *default-database*) nil) - (let ((employees (select 'employee))) - (every #'(lambda (a b) (eq a b)) - employees (select 'employee)))) - t) - - (deftest :oodml/cache/2 - (let ((employees (select 'employee))) - (equal employees (select 'employee :flatp t))) - nil) - - (deftest :oodml/refresh/1 - (let ((addresses (select 'address))) - (equal addresses (select 'address :refresh t))) - t) - - (deftest :oodml/refresh/2 - (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) - (city (slot-value (car addresses) 'city))) - (clsql:update-records [addr] - :av-pairs '((city_field "A new city")) - :where [= [addressid] (slot-value (car addresses) 'addressid)]) - (let* ((new-addresses (select 'address :order-by [addressid] :refresh t :flatp t)) - (new-city (slot-value (car addresses) 'city)) -) - (clsql:update-records [addr] - :av-pairs `((city_field ,city)) - :where [= [addressid] (slot-value (car addresses) 'addressid)]) - (values (equal addresses new-addresses) - city - new-city))) - t "Leningrad" "A new city") - - (deftest :oodml/refresh/3 - (let* ((addresses (select 'address :order-by [addressid] :flatp t))) - (values - (equal addresses (select 'address :refresh t :flatp t)) - (equal addresses (select 'address :flatp t)))) - nil nil) - - (deftest :oodml/refresh/4 - (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) - (*db-auto-sync* t)) - (make-instance 'address :addressid 1000 :city "A new address city") - (let ((new-addresses (select 'address :order-by [addressid] :flatp t :refresh t))) - (delete-records :from [addr] :where [= [addressid] 1000]) - (values - (length addresses) - (length new-addresses) - (eq (first addresses) (first new-addresses)) - (eq (second addresses) (second new-addresses))))) - 2 3 t t) - - - (deftest :oodml/uoj/1 - (progn - (let* ((dea-list (select 'deferred-employee-address :caching nil :order-by ["ea_join" aaddressid] - :flatp t)) - (dea-list-copy (copy-seq dea-list)) - (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list))) - (update-objects-joins dea-list) - (values - initially-unbound - (equal dea-list dea-list-copy) - (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list) - (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list) - (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list)))) - t t t t (1 1 2 2 2)) - - ;; update-object-joins needs to be fixed for multiple keys - #+ignore - (deftest :oodml/uoj/2 - (progn - (clsql:update-objects-joins (list company1)) - (mapcar #'(lambda (e) - (slot-value e 'ecompanyid)) - (company-employees company1))) - (1 1 1 1 1 1 1 1 1 1)) - - (deftest :oodml/big/1 - (let ((objs (clsql:select 'big :order-by [i] :flatp t))) - (values - (length objs) - (do ((i 0 (1+ i)) - (max (expt 2 60)) - (rest objs (cdr rest))) - ((= i (length objs)) t) - (let ((obj (car rest)) - (index (1+ i))) - (unless (and (eql (slot-value obj 'i) index) - (eql (slot-value obj 'bi) (truncate max index))) - (print index) - (describe obj) - (return nil)))))) - 555 t) - - (deftest :oodml/db-auto-sync/1 - (values - (progn - (make-instance 'employee :emplid 20 :groupid 1 - :last-name "Ivanovich") - (select [last-name] :from [employee] :where [= [emplid] 20] - :flatp t :field-names nil)) - (let ((*db-auto-sync* t)) - (make-instance 'employee :emplid 20 :groupid 1 - :last-name "Ivanovich") - (prog1 (select [last-name] :from [employee] :flatp t - :field-names nil - :where [= [emplid] 20]) - (delete-records :from [employee] :where [= [emplid] 20])))) - nil ("Ivanovich")) - - (deftest :oodml/db-auto-sync/2 - (values - (let ((instance (make-instance 'employee :emplid 20 :groupid 1 - :last-name "Ivanovich"))) - (setf (slot-value instance 'last-name) "Bulgakov") - (select [last-name] :from [employee] :where [= [emplid] 20] - :flatp t :field-names nil)) - (let* ((*db-auto-sync* t) - (instance (make-instance 'employee :emplid 20 :groupid 1 - :last-name "Ivanovich"))) - (setf (slot-value instance 'last-name) "Bulgakov") - (prog1 (select [last-name] :from [employee] :flatp t - :field-names nil - :where [= [emplid] 20]) - (delete-records :from [employee] :where [= [emplid] 20])))) - nil ("Bulgakov")) - - (deftest :oodml/db-auto-sync/3 - (values - (progn - (make-instance 'theme :title "test-theme" :vars "test-vars" - :doc "test-doc") - (select [node-id] :from [node] :where [= [title] "test-theme"] - :flatp t :field-names nil)) - (let ((*db-auto-sync* t)) - (make-instance 'theme :title "test-theme" :vars "test-vars" - :doc "test-doc") - (prog1 (select [title] :from [node] :where [= [title] "test-theme"] - :flatp t :field-names nil) - (delete-records :from [node] :where [= [title] "test-theme"]) - (delete-records :from [setting] :where [= [vars] "test-vars"]) - (delete-records :from [theme] :where [= [doc] "test-doc"])))) - nil ("test-theme")) - - (deftest :oodml/db-auto-sync/4 - (values - (let ((inst (make-instance 'theme - :title "test-theme" :vars "test-vars" - :doc "test-doc"))) - (setf (slot-value inst 'title) "alternate-test-theme") - (with-output-to-string (out) - (format out "~a ~a ~a ~a" - (select [title] :from [node] - :where [= [title] "test-theme"] - :flatp t :field-names nil) - (select [vars] :from [setting] - :where [= [vars] "test-vars"] - :flatp t :field-names nil) - (select [doc] :from [theme] - :where [= [doc] "test-doc"] - :flatp t :field-names nil) - (select [title] :from [node] - :where [= [title] "alternate-test-theme"] - :flatp t :field-names nil)))) - (let* ((*db-auto-sync* t) - (inst (make-instance 'theme - :title "test-theme" :vars "test-vars" - :doc "test-doc"))) - (setf (slot-value inst 'title) "alternate-test-theme") - (prog1 - (with-output-to-string (out) - (format out "~a ~a ~a ~a" - (select [title] :from [node] - :where [= [title] "test-theme"] - :flatp t :field-names nil) - (select [vars] :from [setting] - :where [= [vars] "test-vars"] - :flatp t :field-names nil) - (select [doc] :from [theme] - :where [= [doc] "test-doc"] - :flatp t :field-names nil) - (select [title] :from [node] - :where [= [title] "alternate-test-theme"] - :flatp t :field-names nil))) - (delete-records :from [node] :where [= [title] "alternate-test-theme"]) - (delete-records :from [setting] :where [= [vars] "test-vars"]) - (delete-records :from [theme] :where [= [doc] "test-doc"])))) - "NIL NIL NIL NIL" - "NIL (test-vars) (test-doc) (alternate-test-theme)") - - (deftest :oodml/setf-slot-value/1 - (let* ((*db-auto-sync* t) - (instance (make-instance 'employee :emplid 20 :groupid 1))) - (prog1 - (setf - (slot-value instance 'first-name) "Mikhail" - (slot-value instance 'last-name) "Bulgakov") - (delete-records :from [employee] :where [= [emplid] 20]))) - "Bulgakov") - - (deftest :oodml/float/1 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil))) - (height (slot-value emp1 'height))) - (prog1 - (progn - (setf (slot-value emp1 'height) 1.0E0) - (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t - :field-names nil)) - 1)) - (setf (slot-value emp1 'height) height) - (clsql:update-record-from-slot emp1 'height))) - t) - - (deftest :oodml/float/2 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil))) - (height (slot-value emp1 'height))) - (prog1 - (progn - (setf (slot-value emp1 'height) 1.0S0) - (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t - :field-names nil)) - 1)) - (setf (slot-value emp1 'height) height) - (clsql:update-record-from-slot emp1 'height))) - t) - - (deftest :oodml/float/3 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil))) - (height (slot-value emp1 'height))) - (prog1 - (progn - (setf (slot-value emp1 'height) 1.0F0) - (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t - :field-names nil)) - 1)) - (setf (slot-value emp1 'height) height) - (clsql:update-record-from-slot emp1 'height))) - t) - - (deftest :oodml/float/4 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil))) - (height (slot-value emp1 'height))) - (prog1 - (progn - (setf (slot-value emp1 'height) 1.0D0) - (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t - :field-names nil)) - 1)) - (setf (slot-value emp1 'height) height) - (clsql:update-record-from-slot emp1 'height))) - t) - - (deftest :oodml/float/5 - (let* ((emp1 (car (select 'employee - :where [= [slot-value 'employee 'emplid] - 1] - :flatp t - :caching nil))) - (height (slot-value emp1 'height))) - (prog1 - (progn - (setf (slot-value emp1 'height) 1.0L0) - (clsql:update-record-from-slot emp1 'height) - (= (car (clsql:select [height] :from [employee] - :where [= [emplid] 1] - :flatp t - :field-names nil)) - 1)) - (setf (slot-value emp1 'height) height) - (clsql:update-record-from-slot emp1 'height))) - t))) +(deftest :oodml/select/1 + (with-dataset *ds-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")) + +(deftest :oodml/select/2 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'name)) + (clsql:select 'company :flatp t :caching nil))) + ("Widgets Inc.")) + +(deftest :oodml/select/3 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) + (clsql:select 'employee + :where [and [= [slot-value 'employee 'ecompanyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]] + :flatp t + :caching nil))) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :oodml/select/4 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) + (concatenate 'string (slot-value e 'first-name) + " " + (slot-value e 'last-name))) + (clsql:select 'employee :where [= [slot-value 'employee 'first-name] + "Vladimir"] + :flatp t + :order-by [last-name] + :caching nil))) + ("Vladimir Lenin" "Vladimir Putin")) + +(deftest :oodml/select/5 + (with-dataset *ds-employees* + (length (clsql:select 'employee :where [married] :flatp t :caching nil))) + 3) + +(deftest :oodml/select/6 + (with-dataset *ds-employees* + (let ((a (caar (clsql:select 'address :where [= 1 [addressid]] :caching nil)))) + (values + (slot-value a 'street-number) + (slot-value a 'street-name) + (slot-value a 'city) + (slot-value a 'postal-code)))) + 10 "Park Place" "Leningrad" 123) + +(deftest :oodml/select/7 + (with-dataset *ds-employees* + (let ((a (caar (clsql:select 'address :where [= 2 [addressid]] :caching nil)))) + (values + (slot-value a 'street-number) + (slot-value a 'street-name) + (slot-value a 'city) + (slot-value a 'postal-code)))) + nil "" "no city" 0) + +(deftest :oodml/select/8 + (with-dataset *ds-employees* + (mapcar #'(lambda (e) (slot-value e 'married)) + (clsql:select 'employee :flatp t :order-by [emplid] :caching nil))) + (t t t nil nil nil nil nil nil nil)) + +(deftest :oodml/select/9 + (with-dataset *ds-employees* + (mapcar #'(lambda (pair) + (list + (typep (car pair) 'address) + (typep (second pair) 'employee-address) + (slot-value (car pair) 'addressid) + (slot-value (second pair) 'aaddressid) + (slot-value (second pair) 'aemplid))) + (employee-addresses employee1))) + ((t t 1 1 1) (t t 2 2 1))) + +(deftest :oodml/select/10 + (with-dataset *ds-employees* + (mapcar #'(lambda (pair) + (list + (typep (car pair) 'address) + (typep (second pair) 'employee-address) + (slot-value (car pair) 'addressid) + (slot-value (second pair) 'aaddressid) + (slot-value (second pair) 'aemplid))) + (employee-addresses employee2))) + ((t t 2 2 2))) + +(deftest :oodml/select/11 + (with-dataset *ds-employees* + (values (mapcar #'(lambda (x) (slot-value x 'emplid)) + (clsql:select 'employee :order-by '(([emplid] :asc)) + :flatp t)) + (mapcar #'(lambda (x) (slot-value x 'emplid)) + (clsql:select 'employee :order-by '(([emplid] :desc)) + :flatp t)))) + (1 2 3 4 5 6 7 8 9 10) + (10 9 8 7 6 5 4 3 2 1)) + +;; test retrieval of node, derived nodes etc +(deftest :oodml/select/12 + (with-dataset *ds-nodes* + (length (clsql:select 'node :where [node-id] :flatp t :caching nil))) + 11) + +(deftest :oodml/select/13 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'node :where [= 1 [node-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'title)))) + 1 "Bare node") + +(deftest :oodml/select/14 + (with-dataset *ds-nodes* + (length (clsql:select 'setting :where [setting-id] :flatp t :caching nil))) + 4) + +(deftest :oodml/select/15 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'setting :where [= 3 [setting-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'setting-id) + (slot-value a 'title) + (slot-value a 'vars)))) + 3 3 "Setting2" "var 2") + +(deftest :oodml/select/16 + (with-dataset *ds-nodes* + (length (clsql:select 'user :where [user-id] :flatp t :caching nil))) + 2) + +(deftest :oodml/select/17 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'user :where [= 4 [user-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'user-id) + (slot-value a 'title) + (slot-value a 'nick)))) + 4 4 "user-1" "first user") + +(deftest :oodml/select/18 + (with-dataset *ds-nodes* + (length (clsql:select 'theme :where [theme-id] :flatp t :caching nil))) + 2) + +(deftest :oodml/select/19 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'theme :where [= 6 [theme-id]] :flatp t :caching nil)))) + (slot-value a 'theme-id))) + 6) + +(deftest :oodml/select/20 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'theme :where [= 7 [theme-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'theme-id) + (slot-value a 'title) + (slot-value a 'vars) + (slot-value a 'doc) + ))) + 7 7 "theme-2" + nil "second theme") + +;; Some tests to check weird subclassed nodes (node without own table, or subclassed of same) +(deftest :oodml/select/21 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'location :where [= [title] "location-1"] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'title)))) + 8 "location-1") + +(deftest :oodml/select/22 + (with-dataset *ds-nodes* + (let ((a (car (clsql:select 'subloc :where [subloc-id] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'subloc-id) + (slot-value a 'title) + (slot-value a 'loc)))) + 10 10 "subloc-1" "a subloc") + +;; test retrieval is deferred +(deftest :oodm/retrieval/1 + (with-dataset *ds-employees* + (every #'(lambda (e) (not (slot-boundp e 'company))) + (select 'employee :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/2 + (with-dataset *ds-employees* + (every #'(lambda (e) (not (slot-boundp e 'address))) + (select 'deferred-employee-address :flatp t :caching nil))) + t) + +;; :retrieval :immediate should be boundp before accessed +(deftest :oodm/retrieval/3 + (with-dataset *ds-employees* + (every #'(lambda (ea) (slot-boundp ea 'address)) + (select 'employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/4 + (with-dataset *ds-employees* + (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) + (select 'employee-address :flatp t :caching nil))) + (t t t t t)) + +(deftest :oodm/retrieval/5 + (with-dataset *ds-employees* + (mapcar #'(lambda (ea) (typep (slot-value ea 'address) 'address)) + (select 'deferred-employee-address :flatp t :caching nil))) + (t t t t t)) + +(deftest :oodm/retrieval/6 + (with-dataset *ds-employees* + (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) + (select 'employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/7 + (with-dataset *ds-employees* + (every #'(lambda (ea) (slot-boundp (slot-value ea 'address) 'addressid)) + (select 'deferred-employee-address :flatp t :caching nil))) + t) + +(deftest :oodm/retrieval/8 + (with-dataset *ds-employees* + (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) + (select 'employee-address :flatp t :order-by [aaddressid] :caching nil))) + (10 10 nil nil nil)) + +(deftest :oodm/retrieval/9 + (with-dataset *ds-employees* + (mapcar #'(lambda (ea) (slot-value (slot-value ea 'address) 'street-number)) + (select 'deferred-employee-address :flatp t :order-by [aaddressid] :caching nil))) + (10 10 nil nil nil)) + +;; tests update-records-from-instance +(deftest :oodml/update-records/1 + (with-dataset *ds-employees* + (values + (progn + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (clsql:update-records-from-instance employee1) + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin)))))) + "Vladimir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org") + +;; tests update-record-from-slot +(deftest :oodml/update-records/2 + (with-dataset *ds-employees* + (values + (employee-email + (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil))) + (progn + (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") + (clsql:update-record-from-slot employee1 'email) + (employee-email + (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))))) + "lenin@soviet.org" "lenin-nospam@soviet.org") + +;; tests update-record-from-slots +(deftest :oodml/update-records/3 + (with-dataset *ds-employees* + (values + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (clsql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (clsql:select 'employee + :where [= 1 [slot-value 'employee 'emplid]] + :flatp t + :caching nil)))) + (format nil "~a ~a: ~a" + (first-name lenin) + (last-name lenin) + (employee-email lenin)))))) + "Vladimir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org") + +(deftest :oodml/update-records/4 + (with-dataset *ds-nodes* + (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) + (let ((base (car (clsql:select 'node + :where [= 1 [slot-value 'node 'node-id]] + :flatp t :caching nil)))) + (setf (slot-value base 'title) "Altered title") + (clsql:update-records-from-instance base) + (print-fresh-node))))) + "1 Bare node" + "1 Altered title") + +(deftest :oodml/update-records/4-slots ;just like 4, but use slots fns. + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql-sys:update-record-from-slot node 'title) + (clsql-sys:update-record-from-slot node 'vars) + (print-fresh-setting)) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Setting2") + (setf (slot-value node 'vars) "var 2") + (clsql:update-records-from-instance node) + (clsql-sys:update-record-from-slots node '(vars title)) + (print-fresh-setting))))) + "3 Setting2 var 2" + "3 Altered title Altered vars" + "3 Setting2 var 2") + +(deftest :oodml/update-records/5 + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql:update-records-from-instance node) + (print-fresh-setting))))) + "3 Setting2 var 2" + "3 Altered title Altered vars") + +(deftest :oodml/update-records/5-slots + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql-sys:update-record-from-slot node 'title) + (clsql-sys:update-record-from-slot node 'vars) + (print-fresh-setting)) + (let ((node (car (clsql:select 'setting + :where [= 3 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Setting2") + (setf (slot-value node 'vars) "var 2") + (clsql-sys:update-record-from-slots node '(title vars)) + (print-fresh-setting))))) + "3 Setting2 var 2" + "3 Altered title Altered vars" + "3 Setting2 var 2") + +(deftest :oodml/update-records/6 + (with-dataset *ds-nodes* + (flet ((print-fresh-setting () + (let ((node (car (clsql:select 'setting + :where [= 7 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (values + (print-fresh-setting) + (let ((node (car (clsql:select 'setting + :where [= 7 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql:update-records-from-instance node) + (print-fresh-setting)) + (let ((node (car (clsql:select 'setting + :where [= 7 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "theme-2") + (setf (slot-value node 'vars) nil) + (clsql:update-records-from-instance node) + (print-fresh-setting))))) + "7 theme-2 NIL" + "7 Altered title Altered vars" + "7 theme-2 NIL") + +(deftest :oodml/update-records/7 + (with-dataset *ds-nodes* + (flet ((print-fresh-user () + "requery to get what the db has, and print out." + (let ((node (car (clsql:select 'user + :where [= 5 [slot-value 'user 'user-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value node 'user-id) + (slot-value node 'title) + (slot-value node 'nick))))) + (values + (print-fresh-user) + (let ((node (car (clsql:select 'user + :where [= 5 [slot-value 'user 'user-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'nick) "Altered nick") + (clsql:update-records-from-instance node) + (print-fresh-user))))) + "5 user-2 second user" + "5 Altered title Altered nick") + +(deftest :oodml/update-records/8 + (with-dataset *ds-nodes* + (flet ((print-fresh-theme () + (let ((node (car (clsql:select 'theme + :where [= 6 [slot-value 'theme 'theme-id]] + :flatp t :caching nil)))) + (with-slots (node-id setting-id theme-id title vars doc) node + (format nil "~a ~a ~a ~a ~a ~a" + node-id setting-id theme-id + title vars doc))))) + (values + (print-fresh-theme) + (let ((node (car (clsql:select 'setting + :where [= 6 [slot-value 'setting 'setting-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) nil) + (clsql:update-records-from-instance node) + (print-fresh-theme)) + (let ((node (car (clsql:select 'theme + :where [= 6 [slot-value 'theme 'theme-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "Altered title again") + (setf (slot-value node 'doc) "altered doc") + (clsql:update-records-from-instance node) + (print-fresh-theme)) + (let ((node (car (clsql:select 'theme + :where [= 6 [slot-value 'theme 'theme-id]] + :flatp t :caching nil)))) + (setf (slot-value node 'title) "theme-1") + (setf (slot-value node 'vars) "empty") + (setf (slot-value node 'doc) "first theme") + (clsql:update-records-from-instance node) + (print-fresh-theme))))) + "6 6 6 theme-1 empty first theme" + "6 6 6 Altered title NIL first theme" + "6 6 6 Altered title again NIL altered doc" + "6 6 6 theme-1 empty first theme") + +(deftest :oodml/update-records/9 + (with-dataset *ds-nodes* + (flet ((print-fresh-subloc () + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value sl 'subloc-id) + (slot-value sl 'title) + (slot-value sl 'loc))))) + (values + (print-fresh-subloc) + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (setf (slot-value sl 'title) "Altered subloc title") + (setf (slot-value sl 'loc) "Altered loc") + (clsql:update-records-from-instance sl) + (print-fresh-subloc))))) + "10 subloc-1 a subloc" + "10 Altered subloc title Altered loc") + +(deftest :oodml/update-records/9-slots ;like 9, but use slots fns. + (with-dataset *ds-nodes* + (flet ((print-fresh-subloc () + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (format nil "~a ~a ~a" + (slot-value sl 'subloc-id) + (slot-value sl 'title) + (slot-value sl 'loc))))) + (values + (print-fresh-subloc) + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (setf (slot-value sl 'title) "Altered subloc title") + (setf (slot-value sl 'loc) "Altered loc") + (clsql:update-record-from-slot sl 'title) + (clsql:update-record-from-slot sl 'loc) + (print-fresh-subloc)) + (let ((sl (car (clsql:select 'subloc + :where [= 10 [slot-value 'subloc 'subloc-id]] + :flatp t :caching nil)))) + (setf (slot-value sl 'title) "subloc-1") + (setf (slot-value sl 'loc) "a subloc") + (clsql:update-record-from-slot sl '(title loc)) + (print-fresh-subloc))))) + "10 subloc-1 a subloc" + "10 Altered subloc title Altered loc" + "10 subloc-1 a subloc") + + +;; tests update-instance-from-records +(deftest :oodml/update-instance/1 + (with-dataset *ds-employees* + (values + (format nil "~a ~a: ~a" + (slot-value employee1 'first-name) + (slot-value employee1 'last-name) + (slot-value employee1 'email)) + (progn + (clsql:update-records [employee] + :av-pairs '(([first-name] "Ivan") + ([last-name] "Petrov") + ([email] "petrov@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-instance-from-records employee1) + (format nil "~a ~a: ~a" + (slot-value employee1 'first-name) + (slot-value employee1 'last-name) + (slot-value employee1 'email))))) + "Vladimir Lenin: lenin@soviet.org" + "Ivan Petrov: petrov@soviet.org") + +;; tests update-slot-from-record +(deftest :oodml/update-instance/2 + (with-dataset *ds-employees* + (values + (slot-value employee1 'email) + (progn + (clsql:update-records [employee] + :av-pairs '(([email] "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + (clsql:update-slot-from-record employee1 'email) + (slot-value employee1 'email)))) + "lenin@soviet.org" "lenin-nospam@soviet.org") + +;; tests normalisedp update-instance-from-records +(deftest :oodml/update-instance/3 + (with-dataset *ds-nodes* + (values + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (slot-value theme2 'theme-id) + (slot-value theme2 'title) + (slot-value theme2 'vars) + (slot-value theme2 'doc))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 7]) + (clsql:update-records [setting] :av-pairs '(([vars] "Altered vars")) + :where [= [setting-id] 7]) + (clsql:update-records [theme] :av-pairs '(([doc] "Altered doc")) + :where [= [theme-id] 7]) + (clsql:update-instance-from-records theme2) + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (slot-value theme2 'theme-id) + (slot-value theme2 'title) + (slot-value theme2 'vars) + (slot-value theme2 'doc)))))) + "7 theme-2 NIL second theme" + "7 Altered title Altered vars Altered doc") + +(deftest :oodml/update-instance/4 + (with-dataset *ds-nodes* + (values + (progn + (setf loc2 (car (clsql:select 'location + :where [= [node-id] 9] + :flatp t :caching nil))) + (format nil "~a ~a" + (slot-value loc2 'node-id) + (slot-value loc2 'title))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 9]) + (clsql:update-instance-from-records loc2) + (format nil "~a ~a" + (slot-value loc2 'node-id) + (slot-value loc2 'title))))) + "9 location-2" + "9 Altered title") + +(deftest :oodml/update-instance/5 + (with-dataset *ds-nodes* + (values + (format nil "~a ~a ~a" + (slot-value subloc2 'subloc-id) + (slot-value subloc2 'title) + (slot-value subloc2 'loc)) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 11]) + (clsql:update-records [subloc] :av-pairs '(([loc] "Altered loc")) + :where [= [subloc-id] 11]) + (clsql:update-instance-from-records subloc2) + (format nil "~a ~a ~a" + (slot-value subloc2 'subloc-id) + (slot-value subloc2 'title) + (slot-value subloc2 'loc))))) + "11 subloc-2 second subloc" + "11 Altered title Altered loc") + +;; tests update-slot-from-record with normalisedp stuff +(deftest :oodml/update-instance/6 + (with-dataset *ds-nodes* + (values + (slot-value theme1 'doc) + (slot-value theme1 'vars) + (progn + (clsql:update-records [theme] + :av-pairs '(([doc] "altered doc")) + :where [= [theme-id] 6]) + (clsql:update-slot-from-record theme1 'doc) + (slot-value theme1 'doc)) + (progn + (clsql:update-records [setting] + :av-pairs '(([vars] "altered vars")) + :where [= [setting-id] 6]) + (clsql:update-slot-from-record theme1 'vars) + (slot-value theme1 'vars)))) + "first theme" "empty" + "altered doc" "altered vars") + +(deftest :oodml/update-instance/7 + (flet ((print-loc (l) + (format nil "~a: ~a" + (slot-value l 'node-id) (slot-value l 'title))) + (print-subloc (sl) + (format nil "~a: ~a" + (slot-value sl 'node-id) (slot-value sl 'loc)))) + (with-dataset *ds-nodes* + (values + (print-loc loc2) + (print-subloc subloc2) + (progn + (clsql:update-records [node] + :av-pairs '(([title] "altered title")) + :where [= [node-id] 9]) + (clsql:update-slot-from-record loc2 'title) + (print-loc loc2)) + (progn + (clsql:update-records [subloc] + :av-pairs '(([loc] "altered loc")) + :where [= [subloc-id] 11]) + (clsql:update-slot-from-record subloc2 'loc) + (print-subloc subloc2))))) + "9: location-2" "11: second subloc" + "9: altered title" "11: altered loc") + +(deftest :oodml/do-query/1 + (with-dataset *ds-employees* + (let ((result '())) + (clsql:do-query ((e) [select 'employee :order-by [emplid]]) + (push (slot-value e 'last-name) result)) + result)) + ("Putin" "Yeltsin" "Gorbachev" "Chernenko" "Andropov" "Brezhnev" "Kruschev" + "Trotsky" "Stalin" "Lenin")) + +(deftest :oodml/do-query/2 + (with-dataset *ds-employees* + (let ((result '())) + (clsql:do-query ((e c) [select 'employee 'company + :where [= [slot-value 'employee 'last-name] + "Lenin"]]) + (push (list (slot-value e 'last-name) (slot-value c 'name)) + result)) + result)) + (("Lenin" "Widgets Inc."))) + +(deftest :oodml/map-query/1 + (with-dataset *ds-employees* + (clsql:map-query 'list #'last-name [select 'employee :order-by [emplid]])) + ("Lenin" "Stalin" "Trotsky" "Kruschev" "Brezhnev" "Andropov" "Chernenko" + "Gorbachev" "Yeltsin" "Putin")) + +(deftest :oodml/map-query/2 + (with-dataset *ds-employees* + (clsql:map-query 'list #'(lambda (e c) (list (slot-value e 'last-name) + (slot-value c 'name))) + [select 'employee 'company :where [= [slot-value 'employee 'last-name] + "Lenin"]])) + (("Lenin" "Widgets Inc."))) + +(deftest :oodml/iteration/3 + (with-dataset *ds-employees* + (loop for (e) being the records in + [select 'employee :where [< [emplid] 4] :order-by [emplid]] + collect (slot-value e 'last-name))) + ("Lenin" "Stalin" "Trotsky")) + + +(deftest :oodml/cache/1 + (with-dataset *ds-employees* + (progn + (setf (clsql-sys:record-caches *default-database*) nil) + (let ((employees (select 'employee))) + (every #'(lambda (a b) (eq a b)) + employees (select 'employee))))) + t) + +(deftest :oodml/cache/2 + (with-dataset *ds-employees* + (let ((employees (select 'employee))) + (equal employees (select 'employee :flatp t)))) + nil) + +(deftest :oodml/refresh/1 + (with-dataset *ds-employees* + (let ((addresses (select 'address))) + (equal addresses (select 'address :refresh t)))) + t) + +(deftest :oodml/refresh/2 + (with-dataset *ds-employees* + (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) + (city (slot-value (car addresses) 'city))) + (clsql:update-records [addr] + :av-pairs '((city_field "A new city")) + :where [= [addressid] (slot-value (car addresses) 'addressid)]) + (let* ((new-addresses (select 'address :order-by [addressid] :refresh t :flatp t)) + (new-city (slot-value (car addresses) 'city)) + ) + (clsql:update-records [addr] + :av-pairs `((city_field ,city)) + :where [= [addressid] (slot-value (car addresses) 'addressid)]) + (values (equal addresses new-addresses) + city + new-city)))) + t "Leningrad" "A new city") + +(deftest :oodml/refresh/3 + (with-dataset *ds-employees* + (let* ((addresses (select 'address :order-by [addressid] :flatp t))) + (values + (equal addresses (select 'address :refresh t :flatp t)) + (equal addresses (select 'address :flatp t))))) + nil nil) + +(deftest :oodml/refresh/4 + (with-dataset *ds-employees* + (let* ((addresses (select 'address :order-by [addressid] :flatp t :refresh t)) + (*db-auto-sync* t)) + (make-instance 'address :addressid 1000 :city "A new address city") + (let ((new-addresses (select 'address :order-by [addressid] :flatp t :refresh t))) + (delete-records :from [addr] :where [= [addressid] 1000]) + (values + (length addresses) + (length new-addresses) + (eq (first addresses) (first new-addresses)) + (eq (second addresses) (second new-addresses)))))) + 2 3 t t) + + +(deftest :oodml/uoj/1 + (with-dataset *ds-employees* + (progn + (let* ((dea-list (select 'deferred-employee-address :caching nil :order-by ["ea_join" aaddressid] + :flatp t)) + (dea-list-copy (copy-seq dea-list)) + (initially-unbound (every #'(lambda (dea) (not (slot-boundp dea 'address))) dea-list))) + (update-objects-joins dea-list) + (values + initially-unbound + (equal dea-list dea-list-copy) + (every #'(lambda (dea) (slot-boundp dea 'address)) dea-list) + (every #'(lambda (dea) (typep (slot-value dea 'address) 'address)) dea-list) + (mapcar #'(lambda (dea) (slot-value (slot-value dea 'address) 'addressid)) dea-list))))) + t t t t (1 1 2 2 2)) + +;; update-object-joins needs to be fixed for multiple keys +#+ignore +(deftest :oodml/uoj/2 + (progn + (clsql:update-objects-joins (list company1)) + (mapcar #'(lambda (e) + (slot-value e 'ecompanyid)) + (company-employees company1))) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :oodml/big/1 + (with-dataset *ds-big* + (let ((objs (clsql:select 'big :order-by [i] :flatp t))) + (values + (length objs) + (do ((i 0 (1+ i)) + (max (expt 2 60)) + (rest objs (cdr rest))) + ((= i (length objs)) t) + (let ((obj (car rest)) + (index (1+ i))) + (unless (and (eql (slot-value obj 'i) index) + (eql (slot-value obj 'bi) (truncate max index))) + (print index) + (describe obj) + (return nil))))))) + 555 t) + +(deftest :oodml/db-auto-sync/1 + (with-dataset *ds-employees* + (values + (progn + (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich") + (select [last-name] :from [employee] :where [= [emplid] 20] + :flatp t :field-names nil)) + (let ((*db-auto-sync* t)) + (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich") + (prog1 (select [last-name] :from [employee] :flatp t + :field-names nil + :where [= [emplid] 20]) + (delete-records :from [employee] :where [= [emplid] 20]))))) + nil ("Ivanovich")) + +(deftest :oodml/db-auto-sync/2 + (with-dataset *ds-employees* + (values + (let ((instance (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich"))) + (setf (slot-value instance 'last-name) "Bulgakov") + (select [last-name] :from [employee] :where [= [emplid] 20] + :flatp t :field-names nil)) + (let* ((*db-auto-sync* t) + (instance (make-instance 'employee :emplid 20 :groupid 1 + :last-name "Ivanovich"))) + (setf (slot-value instance 'last-name) "Bulgakov") + (prog1 (select [last-name] :from [employee] :flatp t + :field-names nil + :where [= [emplid] 20]) + (delete-records :from [employee] :where [= [emplid] 20]))))) + nil ("Bulgakov")) + +(deftest :oodml/db-auto-sync/3 + (with-dataset *ds-nodes* + (values + (progn + (make-instance 'theme :title "test-theme" :vars "test-vars" + :doc "test-doc") + (select [node-id] :from [node] :where [= [title] "test-theme"] + :flatp t :field-names nil)) + (let ((*db-auto-sync* t)) + (make-instance 'theme :title "test-theme" :vars "test-vars" + :doc "test-doc") + (prog1 (select [title] :from [node] :where [= [title] "test-theme"] + :flatp t :field-names nil) + (delete-records :from [node] :where [= [title] "test-theme"]) + (delete-records :from [setting] :where [= [vars] "test-vars"]) + (delete-records :from [theme] :where [= [doc] "test-doc"]))))) + nil ("test-theme")) + +(deftest :oodml/db-auto-sync/4 + (with-dataset *ds-nodes* + (values + (let ((inst (make-instance 'theme + :title "test-theme" :vars "test-vars" + :doc "test-doc"))) + (setf (slot-value inst 'title) "alternate-test-theme") + (format nil "~a ~a ~a ~a" + (select [title] :from [node] + :where [= [title] "test-theme"] + :flatp t :field-names nil) + (select [vars] :from [setting] + :where [= [vars] "test-vars"] + :flatp t :field-names nil) + (select [doc] :from [theme] + :where [= [doc] "test-doc"] + :flatp t :field-names nil) + (select [title] :from [node] + :where [= [title] "alternate-test-theme"] + :flatp t :field-names nil))) + (let* ((*db-auto-sync* t) + (inst (make-instance 'theme + :title "test-theme" :vars "test-vars" + :doc "test-doc"))) + (setf (slot-value inst 'title) "alternate-test-theme") + (prog1 + (format nil "~a ~a ~a ~a" + (select [title] :from [node] + :where [= [title] "test-theme"] + :flatp t :field-names nil) + (select [vars] :from [setting] + :where [= [vars] "test-vars"] + :flatp t :field-names nil) + (select [doc] :from [theme] + :where [= [doc] "test-doc"] + :flatp t :field-names nil) + (select [title] :from [node] + :where [= [title] "alternate-test-theme"] + :flatp t :field-names nil)) + (delete-records :from [node] :where [= [title] "alternate-test-theme"]) + (delete-records :from [setting] :where [= [vars] "test-vars"]) + (delete-records :from [theme] :where [= [doc] "test-doc"]))))) + "NIL NIL NIL NIL" + "NIL (test-vars) (test-doc) (alternate-test-theme)") + +(deftest :oodml/setf-slot-value/1 + (with-dataset *ds-employees* + (let* ((*db-auto-sync* t) + (instance (make-instance 'employee :emplid 20 :groupid 1))) + (prog1 + (setf + (slot-value instance 'first-name) "Mikhail" + (slot-value instance 'last-name) "Bulgakov") + (delete-records :from [employee] :where [= [emplid] 20])))) + "Bulgakov") + +(deftest :oodml/float/1 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0E0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/2 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0S0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/3 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0F0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/4 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0D0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) + +(deftest :oodml/float/5 + (with-dataset *ds-employees* + (let* ((emp1 (car (select 'employee + :where [= [slot-value 'employee 'emplid] + 1] + :flatp t + :caching nil))) + (height (slot-value emp1 'height))) + (prog1 + (progn + (setf (slot-value emp1 'height) 1.0L0) + (clsql:update-record-from-slot emp1 'height) + (= (car (clsql:select [height] :from [employee] + :where [= [emplid] 1] + :flatp t + :field-names nil)) + 1)) + (setf (slot-value emp1 'height) height) + (clsql:update-record-from-slot emp1 'height)))) + t) +))