configure-stamp
build-stamp
*~
+*.fasl
:components ((:file "package")
(:file "utils")
(:file "test-init")
+ (:file "datasets")
+ (:file "ds-employees")
+ (:file "ds-nodes")
(:file "benchmarks")
(:file "test-internal")
(:file "test-basic")
#+(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))
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)
#: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
(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)
(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)))))
--- /dev/null
+;;;; 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"))
+
--- /dev/null
+(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)
+
--- /dev/null
+(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)
(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
(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))))
#.(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
(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)))
(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])
(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])
(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
(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
(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
(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)))
))
#.(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"))
(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)
*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)
(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)
'(: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))))
(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 ()
#.(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*
'(
; 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))
))
(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)
+))
projects / clsql.git / commitdiff