diff --git a/cl-postgres.asd b/cl-postgres.asd index ac16d12..7570e83 100644 --- a/cl-postgres.asd +++ b/cl-postgres.asd @@ -16,10 +16,10 @@ :author "Marijn Haverbeke " :maintainer "Sabra Crolleton " :license "zlib" - :version "1.32" + :version "1.32.3" :depends-on ("md5" "split-sequence" "ironclad" "cl-base64" "uax-15" (:feature (:or :sbcl :allegro :ccl :clisp :genera - :armedbear :cmucl) + :armedbear :cmucl :lispworks) "usocket") (:feature :sbcl (:require :sb-bsd-sockets))) :components diff --git a/doc/postmodern.org b/doc/postmodern.org index 32c0635..c7181f5 100644 --- a/doc/postmodern.org +++ b/doc/postmodern.org @@ -385,7 +385,13 @@ Immediately commit an open transaction. :CUSTOM_ID: 58a7459f-a1f4-4797-83b5-8b5257ca2cf7 :END: -Roll back the given transaction. +Roll back the given transaction, but the transaction +block is still active. Thus calling abort-transaction in the middle of a +transaction does not end the transaction. Any subsequent statements will still +be executed. Per the Postgresql documentation: ABORT rolls back the current +transaction and causes all the updates made by the transaction to be discarded. +This command is identical in behavior to the standard SQL command ROLLBACK, and +is present only for historical reasons.. ** macro with-savepoint (name &body body) :PROPERTIES: @@ -1091,7 +1097,20 @@ The class must be quoted. :END: → list -Returns list of values that are the primary key of dao. +Returns list of values that are the primary key of dao. Explicit keys takes +priority over col-identity which takes priority over col-primary-key. + +This is likely interesting if you have primary keys which are composed of +more than one slot. Pay careful attention to situations where the primary key +not only has more than one column, but they are actually in a different order +than they are in the database table itself. Obviously the table needs to have +been defined. You can provide a quoted class-name or an instance of a dao. + +** method find-primary-key-column +→ symbol + +Loops through a class's column definitions and returns the first column name +that has bound either col-identity or col-primary-key. ** method dao-exists-p (dao) :PROPERTIES: @@ -1114,6 +1133,26 @@ unbound. Combines make-instance with insert-dao. Make the instance of the given class and insert it into the database, returning the created dao. +** method fetch-defaults (dao) + +→ dao if there were unbound slots with default values, otherwise nil + +Used to fetch the default values of an object on creation. +An example would be creating a dao object with unbounded slots. +Fetch-defaults could then be used to fetch the default values from the database +and bind the unbound slots which have default values. E.g. +#+BEGIN_SRC lisp + (let ((dao (make-instance 'test-data :a 23))) + (pomo:fetch-defaults dao)) +#+END_SRC +** method find-primary-key-column (class) + +→ symbol + +Loops through a class's column definitions and returns +the first column name that has bound either col-identity or col-primary-key. +Returns a symbol. + ** macro define-dao-finalization (((dao-name class) &rest keyword-args) &body body) :PROPERTIES: :ID: 645a03ec-739a-4ee5-b83d-dcbe43ef009a @@ -1283,11 +1322,15 @@ columns. Raises an error when no row matching the dao exists. :END: → boolean -Tries to insert the given dao using insert-dao. If this raises a unique key -violation error, it tries to update it by using update-dao instead. Be aware -that there is a possible race condition here ― if some other process deletes the -row at just the right moment, the update fails as well. Returns a boolean -telling you whether a new row was inserted. +Tries to insert the given dao using insert-dao. If the dao has unbound slots, +those slots will be updated and bound by default data triggered by the +database. If this raises a unique key violation error, it tries to update it by +using update-dao instead. In this case, if the dao has unbound slots, updating +will fail with an unbound slots error. + +Be aware that there is a possible race condition here ― if some other process +deletes the row at just the right moment, the update fails as well. Returns a +boolean telling you whether a new row was inserted. This function is unsafe to use inside of a transaction ― when a row with the given keys already exists, the transaction will be aborted. Use @@ -1304,10 +1347,13 @@ See also: upsert-dao. The transaction safe version of save-dao. Tries to insert the given dao using insert-dao. If this raises a unique key violation error, it tries to update it -by using update-dao instead. Be aware that there is a possible race condition -here ― if some other process deletes the row at just the right moment, the -update fails as well. Returns a boolean telling you whether a new row was -inserted. +by using update-dao instead. If the dao has unbound slots, updating will fail +with an unbound slots error. If the dao has unbound slots, those slots will be +updated and bound by default data triggered by the database. + +Be aware that there is a possible race condition here ― if some other process +deletes the row at just the right moment, the update fails as well. Returns a +boolean telling you whether a new row was inserted. Acts exactly like save-dao, except that it protects its attempt to insert the object with a rollback point, so that a failure will not abort the transaction. @@ -1347,6 +1393,12 @@ actually indicate the existence of record in the database. This method returns two values: the DAO object and a boolean (T if the object was inserted, NIL if it was updated). +IMPORTANT: This is not the same as insert on conflict (sometimes called an upsert) +in Postgresq. An upsert in Postgresql terms is an insert with a fallback of updating +the row if the insert key conflicts with an already existing row. An upsert-dao +in Postmodern terms is the reverse. First you try updating an existing object. If +there is no existing object to oupdate, then you insert a new object. + ** method delete-dao (dao) :PROPERTIES: :ID: f3371904-cd84-4392-a301-0f910bcf1b90 diff --git a/postmodern.asd b/postmodern.asd index c0ca98a..0b619d3 100644 --- a/postmodern.asd +++ b/postmodern.asd @@ -20,7 +20,7 @@ :maintainer "Sabra Crolleton " :homepage "https://github.com/marijnh/Postmodern" :license "zlib" - :version "1.32.1" + :version "1.32.3" :depends-on ("alexandria" "cl-postgres" "s-sql" diff --git a/postmodern/package.lisp b/postmodern/package.lisp index a473e4f..78f89fa 100644 --- a/postmodern/package.lisp +++ b/postmodern/package.lisp @@ -8,6 +8,7 @@ #+postmodern-use-mop (:export #:dao-class #:dao-exists-p #:dao-keys #:query-dao #:select-dao #:get-dao + #:fetch-defaults #:do-query-dao #:do-select-dao #:with-column-writers #:insert-dao #:update-dao #:save-dao #:save-dao/transaction #:upsert-dao @@ -149,6 +150,7 @@ #:list-foreign-keys #:list-unique-or-primary-constraints #:find-primary-key-info + #:find-primary-key-column ;; roles #:list-roles #:list-role-permissions diff --git a/postmodern/prepare.lisp b/postmodern/prepare.lisp index 2394c54..560500e 100644 --- a/postmodern/prepare.lisp +++ b/postmodern/prepare.lisp @@ -86,7 +86,7 @@ Note that it will attempt to automatically reconnect if database-connection-erro or admin-shutdown. It will reset prepared statements triggering an invalid-sql-statement-name error. It will overwrite old prepared statements triggering a duplicate-prepared-statement error." - `(let ((overwrite t)) + `(let ((overwrite ,*allow-overwriting-prepared-statements*)) ,(generate-prepared '(lambda) (next-statement-id) query format))) (defmacro defprepared (name query &optional (format :rows)) @@ -94,7 +94,7 @@ triggering a duplicate-prepared-statement error." function a name which now becomes a top-level function for the prepared statement. The name should not be a string but may be quoted." (when (consp name) (setf name (s-sql::dequote name))) - `(let ((overwrite t)) + `(let ((overwrite ,*allow-overwriting-prepared-statements*)) ,(generate-prepared `(defun ,name) name query format))) (defmacro defprepared-with-names (name (&rest args) diff --git a/postmodern/table.lisp b/postmodern/table.lisp index a4b967f..905e434 100644 --- a/postmodern/table.lisp +++ b/postmodern/table.lisp @@ -72,7 +72,7 @@ regions are deleted, that column would be specified as: Now you can see why the double parens. -We also specify that the table name is not "country" but "countries". (Some style guides +We also specify that the table name is not 'country' but 'countries'. (Some style guides recommend that table names be plural and references to rows be singular.) When inheriting from DAO classes, a subclass' set of columns also contains @@ -98,14 +98,14 @@ slot like this: (defgeneric dao-keys (class) (:documentation "Returns list of slot names that are the primary key of DAO -class. This is likely interesting if you have primary keys which are composed of +class. Explicit keys takes priority over col-identity which takes priority +over col-primary-key. + +This is likely interesting if you have primary keys which are composed of more than one slot. Pay careful attention to situations where the primary key not only has more than one column, but they are actually in a different order -than they are in the database table itself. You can check this with the internal -find-primary-key-info function. Obviously the table needs to have been defined. -The class must be quoted. - - (pomo:find-primary-key-info 'country1)")) +than they are in the database table itself. Obviously the table needs to have +been defined. You can provide a quoted class-name or an instance of a dao.")) (defmethod dao-keys :before ((class dao-class)) (unless (class-finalized-p class) @@ -119,7 +119,8 @@ The class must be quoted. (defgeneric find-primary-key-column (class) (:documentation "Loops through a class's column definitions and returns -the first column name that has bound either col-identity or col-primary-key")) +the first column name that has bound either col-identity or col-primary-key. +Returns a symbol.")) (defmethod find-primary-key-column ((class dao-class)) (loop for x in (dao-column-slots class) do @@ -133,6 +134,12 @@ the first column name that has bound either col-identity or col-primary-key")) (slot-boundp x 'col-primary-key)) (return (slot-definition-name x))))) +(defmethod find-primary-key-column (dao) + (loop for x in (dao-column-slots (class-of dao)) do + (if (or (slot-boundp x 'col-identity) + (slot-boundp x 'col-primary-key)) + (return (slot-definition-name x))))) + (defmethod validate-superclass ((class dao-class) (super-class standard-class)) t) @@ -183,7 +190,6 @@ such a class)." (explore class) found))) - (defmethod finalize-inheritance :after ((class dao-class)) "Building a row reader and a set of methods can only be done after inheritance has been finalised." @@ -303,7 +309,13 @@ rows returned by PostgreSQL, so zero or non-zero number of affected rows may not actually indicate the existence of record in the database. This method returns two values: the DAO object and a boolean (T if the object -was inserted, NIL if it was updated).")) +was inserted, NIL if it was updated). + +IMPORTANT: This is not the same as insert on conflict (sometimes called an upsert) +in Postgresq. An upsert in Postgresql terms is an insert with a fallback of updating +the row if the insert key conflicts with an already existing row. An upsert-dao +in Postmodern terms is the reverse. First you try updating an existing object. If +there is no existing object to oupdate, then you insert a new object.")) (defgeneric get-dao (type &rest args) (:method ((class-name symbol) &rest args) @@ -360,7 +372,14 @@ type serial, which are unknown before insert-dao." (defgeneric fetch-defaults (object) (:documentation "Used to fetch the default values of an object on - creation.")) + creation. An example would be creating a dao object with unbounded slots. +Fetch-defaults could then be used to fetch the default values from the database +and bind the unbound slots which have default values. E.g. + + (let ((dao (make-instance 'test-data :a 23))) + (pomo:fetch-defaults dao)) + +Returns dao if there were unbound slots with default values, nil otherwise.")) (defun %eval (code) (funcall (compile nil `(lambda () ,code)))) @@ -412,19 +431,23 @@ or accessor or reader.)" ;; When all values are primary keys, updating makes no sense. (when value-fields - (let ((tmpl (sql-template `(:update ,table-name + (let ((update-tmpl (sql-template `(:update ,table-name :set ,@(set-fields value-fields) :where ,(test-fields key-fields))))) (defmethod update-dao ((object ,class)) - (when (zerop (execute (apply tmpl + (when (zerop (execute (apply update-tmpl (slot-values object value-fields key-fields)))) (error "Updated row does not exist.")) object) - + ;; upsert in Postgresql terms is an insert with a fallback of updating + ;; the row if the insert key conflicts with an already existing row + ;; Historically an upsert-dao in Postmodern terms is the reverse + ;; updating an existing object and inserting a new object if there + ;; is no existing object to update. (defmethod upsert-dao ((object ,class)) (handler-case - (if (zerop (execute (apply tmpl + (if (zerop (execute (apply update-tmpl (slot-values object value-fields key-fields)))) (values (insert-dao object) t) @@ -432,15 +455,15 @@ or accessor or reader.)" (unbound-slot () (values (insert-dao object) t)))))) - (let ((tmpl (sql-template `(:delete-from ,table-name + (let ((del-tmpl (sql-template `(:delete-from ,table-name :where ,(test-fields key-fields))))) (defmethod delete-dao ((object ,class)) - (execute (apply tmpl (slot-values object key-fields))))) + (execute (apply del-tmpl (slot-values object key-fields))))) - (let ((tmpl (sql-template `(:select * :from ,table-name + (let ((get-tmpl (sql-template `(:select * :from ,table-name :where ,(test-fields key-fields))))) (defmethod get-dao ((type (eql (class-name ,class))) &rest keys) - (car (exec-query *database* (apply tmpl keys) + (car (exec-query *database* (apply get-tmpl keys) (dao-row-reader ,class)))))) (defmethod insert-dao ((object ,class)) @@ -449,28 +472,18 @@ or accessor or reader.)" :do (if (slot-boundp object field) (push field bound) (push field unbound))) - (let* ((counter 0) - (fields (remove-if (lambda (x) (member x ghost-fields)) + (let* ((fields (remove-if (lambda (x) (member x ghost-fields)) bound)) - (places (mapcan (lambda (x) - (incf counter) - (list (field-sql-name x) - (intern (format nil "$~a" counter)))) - fields)) - (values (map 'list (lambda (x) - (slot-value object x)) - fields)) - (returned - (apply - (prepare - (sql-compile + (query (sql-compile `(:insert-into ,table-name - :set ,@places + :set ,@(loop for field in fields + collect (field-sql-name field) + collect (slot-value object field)) ,@(when unbound (cons :returning (mapcar #'field-sql-name - unbound))))) - :row) - values))) + unbound)))))) + (returned + (query query :row))) (when unbound (loop :for value :in returned :for field :in unbound @@ -499,7 +512,8 @@ or accessor or reader.)" (sql-compile (cons :select defaults)) :list) :for slot-name :in names - :do (setf (slot-value object slot-name) value))))) + :do (setf (slot-value object slot-name) value)))) + object) (defmethod fetch-defaults ((object ,class)) nil))) @@ -539,9 +553,10 @@ about the objects, and immediately store it in the new instances." ,@body)) (defparameter *ignore-unknown-columns* nil "Normally, when get-dao, select-dao, -or query-dao finds a column in the database that's not in the DAO class, it will -raise an error. Setting this variable to a non-NIL will cause it to simply -ignore the unknown column.") +save-dao or query-dao finds a column in the database that's not in the DAO class, +it should raise an error. THIS IS NOT ALWAYS THROWING AN ERROR AND IT IS NOT +OBVIOUS WHY. Setting this variable to a non-NIL will cause it to +simply ignore the unknown column.") (defun dao-from-fields (class column-map query-fields result-next-field-generator-fn) @@ -570,18 +585,23 @@ ignore the unknown column.") :collect (dao-from-fields class column-map query-fields #'next-field))))) (defun save-dao (dao) - "Tries to insert the given dao using insert-dao. If this raises a unique key -violation error, it tries to update it by using update-dao instead. Be aware -that there is a possible race condition here ― if some other process deletes -the row at just the right moment, the update fails as well. Returns a boolean -telling you whether a new row was inserted. + "Tries to insert the given dao using insert-dao. If the dao has unbound slots, +those slots will be updated and bound by default data triggered by the +database. If this raises a unique key violation error, it tries to update it by +using update-dao instead. In this case, if the dao has unbound slots, updating +will fail with an unbound slots error. + +Be aware that there is a possible race condition here ― if some other process +deletes the row at just the right moment, the update fails as well. Returns a +boolean telling you whether a new row was inserted. This function is unsafe to use inside of a transaction ― when a row with the given keys already exists, the transaction will be aborted. Use save-dao/transaction instead in such a situation. See also: upsert-dao." - (handler-case (progn (insert-dao dao) t) + (handler-case + (progn (insert-dao dao) t) (cl-postgres-error:unique-violation () (update-dao dao) nil) @@ -592,15 +612,16 @@ See also: upsert-dao." (defun save-dao/transaction (dao) "The transaction safe version of save-dao. Tries to insert the given dao using insert-dao. If this raises a unique key violation error, it tries to update it -by using update-dao instead. Be aware that there is a possible race condition -here ― if some other process deletes the row at just the right moment, the update -fails as well. Returns a boolean telling you whether a new row was inserted. +by using update-dao instead. If the dao has unbound slots, updating will fail +with an unbound slots error. If the dao has unbound slots, those slots will be +updated and bound by default data triggered by the database. Acts exactly like save-dao, except that it protects its attempt to insert the object with a rollback point, so that a failure will not abort the transaction. See also: upsert-dao." - (handler-case (with-savepoint save-dao/transaction (insert-dao dao) t) + (handler-case + (with-savepoint save-dao/transaction (insert-dao dao) t) (cl-postgres-error:unique-violation () (update-dao dao) nil) diff --git a/postmodern/tests/test-dao.lisp b/postmodern/tests/test-dao.lisp index 892f8c1..0638dc4 100644 --- a/postmodern/tests/test-dao.lisp +++ b/postmodern/tests/test-dao.lisp @@ -17,6 +17,7 @@ (:table-name dao-test) (:keys id)) +;; This class has fewer slots than the database table has fields (defclass test-data-short () ((id :col-type serial :initarg :id :accessor test-id) (a :col-type (or (varchar 100) db-null) :initarg :a :accessor test-a)) @@ -24,13 +25,20 @@ (:table-name dao-test) (:keys id)) -(defclass test-data-short-wrong-1 () +;; This class is short and has a slot that has a col-type different than the database table +;; slot a has a numeric col-type, but in the database table it is a string +;; Postmodern col-types do not control the actual parameter type. +;; THIS SHOULD BE REVISITED WHEN WE DO THE BINARY PARAMETERS +(defclass test-data-short-wrong-col-type () ((id :col-type serial :initarg :id :accessor test-id) (a :col-type (or numeric db-null) :initarg :a :accessor test-a)) (:metaclass postmodern:dao-class) (:table-name dao-test) (:keys id)) +;; This class has the same number of slots, but one is the wrong type +;; Postmodern col-types do not control the actual parameter type. +;; THIS SHOULD BE REVISITED WHEN WE DO THE BINARY PARAMETERS (defclass test-data-d-string () ((id :col-type serial :initarg :id :accessor test-id) (a :col-type (or (varchar 100) db-null) :initarg :a :accessor test-a) @@ -41,31 +49,109 @@ (:table-name dao-test) (:keys id)) -(defclass test-data-3 () +(defclass test-data-multicolumn-key () + ((id :col-type serial :initarg :id :accessor test-id) + (a :col-type (or (varchar 100) db-null) :initarg :a :accessor test-a) + (b :col-type boolean :col-default nil :initarg :b :accessor test-b) + (c :col-type integer :col-default 0 :initarg :c :accessor test-c) + (d :col-type numeric :col-default 0.0 :initarg :d :accessor test-d)) + (:metaclass postmodern:dao-class) + (:table-name dao-test-mk) + (:keys id a)) + +(defclass test-data-not-serial-key () + ((id :col-type integer :initarg :id :accessor id) + (username :col-type text :unique t :initarg :username :accessor username) + (department-id :col-type integer :initarg :department-id :accessor department-id)) + (:metaclass dao-class) + (:table-name users1) + (:keys username)) + +(defclass test-data-col-identity () ((id :col-type integer :col-identity t :accessor id) - (username :col-type text :unique t :initarg :username :accessor username) - (department-id :col-type integer :references ((departments id)) - :initarg :department-id :accessor department-id) - (len :col-type (or interval db-null) :col-interval :hour-to-minute)) + (username :col-type text :unique t :initarg :username :accessor username) + (department-id :col-type integer :initarg :department-id :accessor department-id)) + (:metaclass dao-class) + (:table-name users1) + (:keys username)) + +(defclass test-data-col-primary-key () + ((id :col-type integer :accessor id) + (username :col-type text :col-primary-key t :unique t :initarg :username :accessor username) + (department-id :col-type integer :initarg :department-id :accessor department-id)) + (:metaclass dao-class) + (:table-name users1)) + +(defclass test-data-col-identity-no-keys () + ((id :col-type integer :col-identity t :accessor id) + (username :col-type text :unique t :initarg :username :accessor username) + (department-id :col-type integer :initarg :department-id :accessor department-id)) (:metaclass dao-class) (:table-name users1)) +(defclass test-data-col-identity-with-references () + ((id :col-type integer :col-identity t :accessor id) + (username :col-type text :unique t :initarg :username :accessor username) + (department-id :col-type integer :col-references ((departments id)) + :initarg :department-id :accessor department-id)) + (:metaclass dao-class) + (:table-name usersr)) + +(defclass test-data-department () + ((id :col-type integer :col-identity t :accessor id) + (department-name :col-type text :unique t :initarg :department-name :accessor department-name)) + (:metaclass dao-class) + (:table-name departments)) + +(defclass from-test-data () + ((id :col-type serial :initarg :id :accessor id) + (flight :col-type (or integer db-null) :initarg :flight :accessor flight) + (from :col-type (or (varchar 100) db-null) :initarg :from :accessor from) + (to-destination :col-type (or (varchar 100) db-null) + :initarg :to-destination :accessor to-destination)) + (:metaclass dao-class) + (:table-name from-test) + (:keys id from)) + +(defun dao-test-table-fixture () + "Drops and recreates the dao-test table" + (when (table-exists-p 'dao-test) + (query (:drop-table :if-exists 'dao-test :cascade))) + (execute (dao-table-definition 'test-data))) + +(defun dao-test-table-fixture-mk () + "Drops and recreates the dao-test-mk table" + (when (table-exists-p 'dao-test-mk) + (query (:drop-table :if-exists 'dao-test-mk :cascade))) + (execute (dao-table-definition 'test-data-multicolumn-key))) + +(defun dao-test-table-fixture-references () + "Drops and recreates the usersr and departments tables" + (when (table-exists-p 'usersr) + (query (:drop-table :if-exists 'usersr :cascade))) + (when (table-exists-p 'departments) + (query (:drop-table :if-exists 'departments :cascade))) + (execute (dao-table-definition 'test-data-department)) + (execute (dao-table-definition 'test-data-col-identity-with-references))) + +(defun dao-test-table-fixture-not-serial-key () + "Drops and recreates the users1 table" + (when (table-exists-p 'users1) + (query (:drop-table :if-exists 'users1 :cascade))) + (execute (dao-table-definition 'test-data-not-serial-key))) + (test dao-class (with-test-connection - (when (table-exists-p 'dao-test) - (query (:drop-table :if-exists 'dao-test :cascade))) - (is (not (table-exists-p 'dao-test))) + (dao-test-table-fixture) (is (equal (dao-table-definition 'test-data) "CREATE TABLE dao_test (id SERIAL NOT NULL, a VARCHAR(100) DEFAULT NULL, b BOOLEAN NOT NULL DEFAULT false, c INTEGER NOT NULL DEFAULT 0, d NUMERIC NOT NULL DEFAULT 0.0, PRIMARY KEY (id))")) (is (equal (dao-keys (find-class 'test-data)) '(ID))) - (dao-keys (make-instance 'test-data :id 1)) - '(1) - (execute (dao-table-definition 'test-data)) - (is (table-exists-p 'dao-test)) + (is (equal (dao-keys (make-instance 'test-data :id 1)) + '(1))) + (is (member :dao-test (list-tables))) + (is (null (select-dao 'test-data))) (protect - (is (member :dao-test (list-tables))) - (is (null (select-dao 'test-data))) (let ((dao (make-instance 'test-data :a "quux"))) (signals error (test-id dao)) (insert-dao dao) @@ -80,117 +166,376 @@ (let ((new-database-dao (get-dao 'test-data id))) (is (eq (test-b new-database-dao) t)) (is (eq (test-b database-dao) nil)) - (delete-dao dao)))) - (is (not (select-dao 'test-data))) + (delete-dao dao))) + (is (not (select-dao 'test-data)))) (execute (:drop-table 'dao-test :cascade))))) -(test save-upsert-dao +(test dao-keys + "Explicit keys takes priority over col-identity which takes priority over col-primary-key" + (is (equal (dao-keys (find-class 'test-data)) + '(ID))) + (is (equal (dao-keys (find-class 'test-data-col-identity)) + '(USERNAME))) + (is (equal (dao-keys (find-class 'test-data-col-identity-no-keys)) + '(ID))) + (is (equal (dao-keys (find-class 'test-data-col-primary-key)) + '(USERNAME)))) + +(test single-column-primary-keys + (dao-test-table-fixture) + (let ((dao (make-instance 'test-data :a "quux")) + (dao-col-identity (make-instance 'test-data-not-serial-key :a "quux-ci"))) + (is (equal (find-primary-key-column 'test-data) + nil)) + (is (equal (find-primary-key-column dao-col-identity) + nil)) + (is (equal (find-primary-key-column dao) + nil)) + (is (equal (find-primary-key-column 'test-data-col-identity) + 'id)) + (is (equal (find-primary-key-column + (class-of (make-instance 'test-data-col-identity))) + 'id)) + (is (equal (pomo::dao-keys 'test-data) + '(id))) + (with-test-connection + (protect + (progn + (is (equal (find-primary-key-info + (dao-table-name + (class-of (make-instance 'test-data :a "quux")))) + '(("id" "integer")))) + (is (equal (dao-keys 'test-data) + '(id)))) + (execute (:drop-table 'dao-test :cascade)))))) + +(test multi-column-primary-keys + (dao-test-table-fixture-mk) + (is (equal (find-primary-key-column 'test-data-multicolumn-key) + nil)) (with-test-connection - (when (table-exists-p 'dao-test) - (query (:drop-table :if-exists 'dao-test :cascade))) - (is (not (table-exists-p 'dao-test))) - (execute (dao-table-definition 'test-data)) - (is (table-exists-p 'dao-test)) (protect - (let ((dao (make-instance 'test-data :a "quux"))) - (save-dao dao) - (is (equal (test-a (get-dao 'test-data (test-id dao))) "quux")) - (setf (test-a dao) "bar") - (upsert-dao dao) - (is (equal (test-a (get-dao 'test-data (test-id dao))) "bar")))))) + (is (equal (find-primary-key-info 'dao-test-mk) + '(("id" "integer") ("a" "character varying(100)")))) + (is (equal (dao-keys 'test-data-multicolumn-key) + '(id a))) + (execute (:drop-table 'dao-test-mk :cascade))))) + +(test dao-column-slots + (is (equal (mapcar #'pomo::slot-definition-name + (pomo::dao-column-slots + (class-of (make-instance 'test-data-col-identity + :id 1 + :username "duck" + :department-id 1)))) + '(ID USERNAME DEPARTMENT-ID))) + (is (equal (mapcar #'pomo::slot-definition-name + (pomo::dao-column-slots (find-class 'test-data-col-identity))) + '(ID USERNAME DEPARTMENT-ID)))) + +(test dao-column-fields + (is (equal (pomo::dao-column-fields (find-class 'test-data-col-identity)) + '(ID USERNAME DEPARTMENT-ID))) + (is (equal (pomo::dao-column-fields + (class-of + (make-instance 'test-data-col-identity + :id 1 :username "duck" :department-id 1))) + '(ID USERNAME DEPARTMENT-ID)))) + +(test dao-table-name + (is (equal (dao-table-name 'test-data-col-identity) + 'USERS1))) + +(test dao-superclasses + (is (equal (class-name + (class-of (first (pomo::dao-superclasses (find-class 'test-data-col-identity))))) + 'dao-class))) + +(test insert-dao-base + (with-test-connection + (dao-test-table-fixture) + (protect + (progn + (insert-dao (make-instance 'test-data :a "unbound-stuff-here")) + (is (equal (query "select * from dao_test") + '((1 "unbound-stuff-here" NIL 0 0)))) + ;; The following will trigger a duplicate key error + (signals error (insert-dao (make-instance 'test-data :id 1 :a "unbound-stuff-here"))) + (is (equal (query "select * from dao_test") + '((1 "unbound-stuff-here" NIL 0 0)))) + (signals error (insert-dao (make-instance 'test-data :id 1 :a "bar" :b t :c 17 :d 13.2))) + (is (equal (query "select * from dao_test") + '((1 "unbound-stuff-here" NIL 0 0)))) + (insert-dao (make-instance 'test-data :a "bar" :b t :c 17 :d 13.2)) + (is (equal (query "select * from dao_test") + '((1 "unbound-stuff-here" NIL 0 0) (2 "bar" T 17 66/5))))) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) -(test save-identical-dao-error +(test save-dao-base (with-test-connection - (when (table-exists-p 'dao-test) - (query (:drop-table :if-exists 'dao-test :cascade))) - (is (not (table-exists-p 'dao-test))) - (execute (dao-table-definition 'test-data)) - (is (table-exists-p 'dao-test)) + (dao-test-table-fixture) (protect (let ((dao (make-instance 'test-data :a "quux"))) - (save-dao dao) - (is (equal (test-a (get-dao 'test-data (test-id dao))) "quux")) + (is (save-dao dao)) ; returns a boolean to indicate a new row was inserted (setf (test-a dao) "bar") - (is (not (save-dao dao))))))) + (is (equal (test-id dao) + 1)) + (is (equal (test-d dao) + 0)) + (is (not (save-dao dao))) ; returns boolean nil showing no new row was inserted + (is (equal (test-a (get-dao 'test-data (test-id dao))) "bar"))) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) -(test save-dao +(test save-dao-with-transaction (with-test-connection - (when (table-exists-p 'dao-test) - (query (:drop-table :if-exists 'dao-test :cascade))) - (is (not (table-exists-p 'dao-test))) - (execute (dao-table-definition 'test-data)) - (is (table-exists-p 'dao-test)) + (dao-test-table-fixture) (protect - (let ((dao (make-instance 'test-data :a "quux"))) - (is (save-dao dao)) + (let ((dao (make-instance 'test-data :a "quux"))) + (with-transaction () + (save-dao dao)) + (is (equal (query "select * from dao_test") + '((1 "quux" NIL 0 0)))) (setf (test-a dao) "bar") - (is (not (save-dao dao))) - (is (equal (test-a (get-dao 'test-data (test-id dao))) "bar")) (signals database-error (with-transaction () (save-dao dao))) (with-transaction () - (is (not (save-dao/transaction dao))))) - (let ((short-dao (make-instance 'test-data-short :a "first short"))) + (is (equal (query "select * from dao_test") + '((1 "quux" NIL 0 0)))) + (is (not (save-dao/transaction dao))) + (is (equal (query "select * from dao_test") + '((1 "bar" NIL 0 0)))))) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) + +(test save-dao-with-same-key + (with-test-connection + (dao-test-table-fixture) + (protect + (let ((dao (make-instance 'test-data :a "quux"))) + (save-dao dao) + (is (equal (test-id dao) + 1)) + (is (equal (query "select * from dao_test") + '((1 "quux" NIL 0 0)))) + (setf (test-a dao) "bar") + (save-dao dao) + (is (equal (query "select * from dao_test") + '((1 "bar" NIL 0 0))))) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) + +(test save-dao-smaller-than-table + (with-test-connection + (dao-test-table-fixture) + (protect + (let ((short-dao (make-instance 'test-data-short :a "first short"))) (save-dao short-dao) (is (equalp (query (:select '* :from 'dao-test) :alists) - '(((:ID . 1) (:A . "bar") (:B) (:C . 0) (:D . 0)) - ((:ID . 2) (:A . "first short") (:B) (:C . 0) (:D . 0)))))) - (let ((dao-short-wrong (make-instance 'test-data-short-wrong-1 :a 12.75))) + '(((:ID . 1) (:A . "first short") (:B) (:C . 0) (:D . 0))))) + (setf *ignore-unknown-columns* t) + (is (equal (test-a (get-dao 'test-data-short 1)) + "first short")) + (setf *ignore-unknown-columns* nil)) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) + +(test save-short-dao-with-bad-col-type + (with-test-connection + (dao-test-table-fixture) + (protect + (let ((dao-short-wrong (make-instance 'test-data-short-wrong-col-type :a 12.75))) (save-dao dao-short-wrong) (is (equalp (query (:select '* :from 'dao-test) :alists) - '(((:ID . 1) (:A . "bar") (:B) (:C . 0) (:D . 0)) - ((:ID . 2) (:A . "first short") (:B) (:C . 0) (:D . 0)) - ((:ID . 3) (:A . "12.75") (:B) (:C . 0) (:D . 0)))))) - (let ((dao-d-string (make-instance 'test-data-d-string :a "D string" :b nil :c 14 - :d 18.78))) - (save-dao dao-d-string) - (is (equalp (query (:select '* :from 'dao-test) :alists) - '(((:ID . 1) (:A . "bar") (:B) (:C . 0) (:D . 0)) - ((:ID . 2) (:A . "first short") (:B) (:C . 0) (:D . 0)) - ((:ID . 3) (:A . "12.75") (:B) (:C . 0) (:D . 0)) - ((:ID . 4) (:A . "D string") (:B) (:C . 14) (:D . 939/50))))) - (is (equal 939/50 (test-d (get-dao 'test-data-d-string - (test-id dao-d-string))))) - (is (equal (test-a (first (query (:select '* :from 'dao-test :where (:= 'id 1)) - (:dao test-data)))) - "bar"))) - (is (equal (length (query (:select '* :from 'dao-test) (:dao test-data))) - 4)) - (is (equal (type-of (first (with-test-connection - (query (:select '* :from 'dao-test) - (:dao test-data))))) - 'TEST-DATA)) - (is (equal (type-of (first (with-test-connection - (query (:select '* :from 'dao-test) - (:dao test-data-d-string))))) - 'TEST-DATA-D-STRING)) - (let ((dao (make-instance 'test-data-d-string :a "D string" :b nil :c 14 - :d "Trying string"))) - (signals error (with-transaction () (save-dao dao)))) - (setf *ignore-unknown-columns* t) - (is (equal (test-a (get-dao 'test-data-short 3)) - "12.75")) - (setf *ignore-unknown-columns* nil) + '(((:ID . 1) (:A . "12.75") (:B) (:C . 0) (:D . 0)))))) (with-test-connection (execute (:drop-table 'dao-test :cascade)))))) +(test save-dao-with-bad-col-type + "Tests saving a dao when slot d, accessor test-d has a text col-type and the table is numeric." + (with-test-connection + (dao-test-table-fixture) + (protect + (progn + (let ((dao-d-string (make-instance 'test-data-d-string :a "D string" :b nil :c 14 + :d "abcd"))) + (signals error (save-dao dao-d-string)) ; invalid type + (setf (test-d dao-d-string) "18.75") + (save-dao dao-d-string) + (is (equal (query (:select '* :from 'dao-test)) + '((1 "D string" NIL 14 75/4)))) + (setf (test-d dao-d-string) 18.75) + (save-dao dao-d-string) + (is (equal (query (:select '* :from 'dao-test)) + '((1 "D string" NIL 14 75/4)))))) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) + +(test save-dao-with-col-identity + "Note the difference between make-instance and make-dao" + (with-test-connection + (dao-test-table-fixture-references) + (protect + (let ((dao (make-dao 'test-data-department :department-name "Math"))) + (is (equal (query "select * from departments") + '((1 "Math")))) + (setf (department-name dao) "German") + (signals error (save-dao dao)) ; save-dao tries to insert and cannot insert over the id + (update-dao dao) + (is (equal (query "select * from departments") + '((1 "German")))) + (insert-dao (make-instance 'test-data-department :department-name "Philosophy")) + (is (equal (query "select * from departments") + '((1 "German") (2 "Philosophy")))) + (make-dao 'test-data-department :department-name "Economics") + (is (equal (query "select * from departments") + '((1 "German") (2 "Philosophy") (3 "Economics")))) + (let ((dao (make-instance 'test-data-department :department-name "Geopolitics"))) + (upsert-dao dao)) + (is (equal (query "select * from departments") + '((1 "German") (2 "Philosophy") (3 "Economics") (4 "Geopolitics")))))))) + +(test returning-different-dao-types + "Demonstrates that daos do not enforce slot types. The database will enforce the slot types +so there is a single source of type truth." + (with-test-connection + (dao-test-table-fixture) + (protect + (progn + (let ((dao-d-string (make-instance 'test-data-d-string :a "D string" :b nil :c 14 + :d "18.75"))) + (save-dao dao-d-string) + (is (equal (query (:select '* :from 'dao-test)) + '((1 "D string" NIL 14 75/4))))) + (is (equal (type-of (query (:select '* :from 'dao-test) + (:dao test-data :single))) + 'TEST-DATA)) + (is (equal (type-of (query (:select '* :from 'dao-test) + (:dao test-data-d-string :single))) + 'TEST-DATA-D-STRING)) + (is (equal (test-d (query (:select '* :from 'dao-test) + (:dao test-data-d-string :single))) + 75/4))) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) + +(test update-dao + (with-test-connection + (dao-test-table-fixture) + (protect + (progn + (save-dao (make-instance 'test-data :id 1 :a "bar")) + ;; error signaled next line due to trying to update using a dao with unbounded slots + (signals error (update-dao (make-instance 'test-data :id 1 :a "bar"))) + (update-dao (make-instance 'test-data :id 1 :a "bar" :b t :c 17 :d 13.2)) + (is (equal (query "select * from dao_test") + '((1 "bar" T 17 66/5))))) + (with-test-connection + (execute (:drop-table 'dao-test :cascade)))))) + +(test save-upsert-dao-with-serial + (with-test-connection + (dao-test-table-fixture) + (protect + (let ((dao (make-instance 'test-data :a "quux"))) + (save-dao dao) + (is (equal (query "select * from dao_test") + '((1 "quux" NIL 0 0)))) + (is (equal (test-a (get-dao 'test-data (test-id dao))) "quux")) + (setf (test-a dao) "bar") + (upsert-dao dao) + (is (equal (test-a (get-dao 'test-data (test-id dao))) "bar")) + (is (equal (query "select * from dao_test") + '((1 "bar" NIL 0 0)))) + (signals error (update-dao (make-instance 'test-data :id 1 :a "cover?"))) ; unbound :b + (signals error (upsert-dao (make-instance 'test-data :id 1 :a "cover?"))) ; duplicate key + (upsert-dao (make-instance 'test-data :a "cover?")) + (is (equal (query "select * from dao_test") + '((1 "bar" NIL 0 0) (2 "cover?" NIL 0 0)))))))) + +(test save-upsert-dao-not-serial + (with-test-connection + (dao-test-table-fixture-not-serial-key) + (protect + (let ((dao (make-instance 'test-data-not-serial-key :id 1 :username "duck"))) + (signals error (save-dao dao)) ; unbound department-id + (setf (department-id dao) 12) + (save-dao dao) + (is (equal (query "select * from users1") + '((1 "duck" 12)))) + (is (equal (username (get-dao 'test-data-not-serial-key (username dao))) + "duck")) + (setf (department-id dao) 13) + (upsert-dao dao) + (is (equal (query "select * from users1") + '((1 "duck" 13)))) + (setf (username dao) "goose") + (setf (department-id dao) 17) + (upsert-dao dao) + (is (equal (query "select * from users1") + '((1 "duck" 13) (1 "goose" 17)))) + (is (equal (department-id (get-dao 'test-data-not-serial-key (username dao))) + 17)) + (signals error (update-dao (make-instance 'test-data-not-serial-key + :id 1 :username "turkey" :department-id 43))) + ;; update row does not exist + (is (equal (query "select * from users1") + '((1 "duck" 13) (1 "goose" 17)))) + (upsert-dao (make-instance 'test-data-not-serial-key + :id 1 :username "chicken" :department-id 3)) + (is (equal (query "select * from users1") + '((1 "duck" 13) (1 "goose" 17) (1 "chicken" 3)))) + (upsert-dao (make-instance 'test-data-not-serial-key + :id 1 :username "duck" :department-id 3)) + (is (equal (query "select * from users1") + '((1 "goose" 17) (1 "chicken" 3) (1 "duck" 3)))) + (update-dao (make-instance 'test-data-not-serial-key + :id 1 :username "chicken" :department-id 3)) + (is (equal (query "select * from users1") + '((1 "goose" 17) (1 "duck" 3) (1 "chicken" 3)))) + (upsert-dao (make-instance 'test-data-not-serial-key + :id 1 :username "penguin" :department-id 43)) + (is (equal (query "select * from users1") + '((1 "goose" 17) (1 "duck" 3) (1 "chicken" 3) (1 "penguin" 43)))) + (signals error (update-dao (make-instance 'test-data-not-serial-key + :id 1 :username "turkey" :department-id 43))) + ;; still no turkey to update + (is (equal (query "select * from users1") + '((1 "goose" 17) (1 "duck" 3) (1 "chicken" 3) (1 "penguin" 43)))))))) + +(test dao-create-table-with-references + (is (equal (dao-table-definition 'test-data-col-identity-with-references) + "CREATE TABLE usersr (id INTEGER NOT NULL PRIMARY KEY generated always as identity, username TEXT NOT NULL, department_id INTEGER NOT NULL REFERENCES departments(id) MATCH SIMPLE ON DELETE RESTRICT ON UPDATE RESTRICT)")) + (with-test-connection + (dao-test-table-fixture-references) + (protect + (progn + (signals error (insert-dao (make-instance 'test-data--col-identity-with-references + :username "user-1" :department-id 1))) + (format t "Departments ~a~%" (query "select * from departments")) + (insert-dao (make-instance 'test-data-department :department-name "department 1" + :department-id 1)) + (format t "Departments ~a~%" (query "select * from departments")) + (insert-dao (make-instance 'test-data-col-identity-with-references + :username "user-1" :department-id 1)) + (is (equal (query "select * from usersr") + '((1 "user-1" 1)))) + (is (equal (username (get-dao 'test-data-col-identity-with-references 1)) + "user-1"))) + (progn + (query (:drop-table :if-exists 'usersr :cascade)) + (query (:drop-table :if-exists 'departments :cascade)))))) + (test query-drop-table-1 (with-test-connection - (unless (pomo:table-exists-p 'dao-test) - (execute (dao-table-definition 'test-data))) + (dao-test-table-fixture) (protect (is (member :dao-test (with-test-connection (pomo:list-tables)))) (pomo:query (:drop-table :dao-test)) (is (not (member :dao-test (with-test-connection (pomo:list-tables)))))))) -(defclass test-oid () - ((oid :col-type integer :ghost t :accessor test-oid) - (a :col-type string :initarg :a :accessor test-a) - (b :col-type string :initarg :b :accessor test-b)) - (:metaclass dao-class) - (:keys a)) - (defclass test-col-name () ((a :col-type string :col-name aa :initarg :a :accessor test-a) (b :col-type string :col-name bb :initarg :b :accessor test-b) @@ -201,11 +546,14 @@ (:keys a)) (test dao-class-col-name + "Test the use of col-name in daos" (with-test-connection - (execute "CREATE TEMPORARY TABLE test_col_name (aa text primary key, bb text not null, c text not null, + (execute "CREATE TEMPORARY TABLE test_col_name (aa text primary key, bb text not null, c text not null, \"from\" text not null, \"to\" text not null)") (let ((o (make-instance 'test-col-name :a "1" :b "2" :c "3" :d "Reykjavík" :e "Garðabær"))) (save-dao o) + (is (equal (query "select * from test_col_name" :alists) + '(((:AA . "1") (:BB . "2") (:C . "3") (:FROM . "Reykjavík") (:TO . "Garðabær"))))) (let ((oo (get-dao 'test-col-name "1"))) (is (string= "1" (test-a oo))) (is (string= "2" (test-b oo))) @@ -220,12 +568,12 @@ (is (string= "b" (test-b (get-dao 'test-col-name "1")))) (is (string= "3" (test-c (get-dao 'test-col-name "1")))) (is (string= "Vestmannaeyjar" (test-d (get-dao 'test-col-name "1"))))) - (with-test-connection - (execute "CREATE TEMPORARY TABLE test_col_name (aa text primary key default md5(random()::text), bb text not null, c text not null, + (with-test-connection + (execute "CREATE TEMPORARY TABLE test_col_name (aa text primary key default md5(random()::text), bb text not null, c text not null, \"from\" text not null, \"to\" text not null)") - (let ((o (make-instance 'test-col-name :b "2" :c "3" :d "Reykjavík" :e "Garðabær"))) - (fiveam:finishes - (insert-dao o))))) + (let ((o (make-instance 'test-col-name :b "2" :c "3" :d "Reykjavík" :e "Garðabær"))) + (fiveam:finishes + (insert-dao o))))) ;;; For threading tests (defvar *dao-update-lock* (bt:make-lock)) @@ -244,7 +592,6 @@ (let ((a (make-class (write-to-string (gensym))))) (is (not (equal nil (make-instance a :id 12 :a "six" :b t)))))) - (test dao-class-threads (with-test-connection (unless (pomo:table-exists-p 'dao-test) @@ -272,14 +619,6 @@ (test reserved-column-names-defclass (with-test-connection - (defclass from-test-data () - ((id :col-type serial :initarg :id :accessor id) - (flight :col-type (or integer db-null) :initarg :flight :accessor flight) - (from :col-type (or (varchar 100) db-null) :initarg :from :accessor from) - (to-destination :col-type (or (varchar 100) db-null) :initarg :to-destination :accessor to-destination)) - (:metaclass dao-class) - (:table-name from-test) - (:keys id from)) (when (pomo:table-exists-p "from-test") (execute (:drop-table "from-test" :cascade))) (when (pomo:table-exists-p 'from-test-data1) @@ -293,9 +632,15 @@ '("id" "flight" "from" "to_destination"))) (is (equal (pomo:find-primary-key-info 'public.from-test) '(("id" "integer") ("from" "character varying(100)")))) - (let* ((item1 (make-instance 'from-test-data :flight 1 :from "Reykjavík" :to-destination "Seyðisfjörður")) - (item2 (make-instance 'from-test-data :flight 2 :from "Stykkishólmur" :to-destination "Reykjavík")) - (item3 (make-instance 'from-test-data :flight 3 :from "Stykkishólmur" :to-destination "Reykjavík"))) + (let* ((item1 + (make-instance 'from-test-data + :flight 1 :from "Reykjavík" :to-destination "Seyðisfjörður")) + (item2 + (make-instance 'from-test-data + :flight 2 :from "Stykkishólmur" :to-destination "Reykjavík")) + (item3 + (make-instance 'from-test-data + :flight 3 :from "Stykkishólmur" :to-destination "Reykjavík"))) (is (equal "Reykjavík" (from item1))) (is (equal "Seyðisfjörður" (to-destination item1))) (insert-dao item1) @@ -319,3 +664,57 @@ (delete-dao item3) (is (not (get-dao 'from-test-data 3 "Stykkishólmur"))) (execute (:drop-table 'from-test :cascade))))) + +(test fetch-defaults + (with-test-connection + (dao-test-table-fixture) + (protect + (let ((dao (make-instance 'test-data :a "something")) + (short-dao (make-instance 'test-data-short))) + (signals error (test-b dao)) ; unbound slot b + (pomo:fetch-defaults dao) + (is (equal (test-b dao) + nil)) + (is (equal (test-c dao) + 0)) + (signals error (test-id short-dao)) + (pomo:fetch-defaults short-dao) + (signals error (test-id short-dao))) + (execute (:drop-table 'dao-test :cascade))))) + +(test generate-dao-query + (is (equal (pomo::generate-dao-query 'test-data) + '(:SELECT '* :FROM (DAO-TABLE-NAME (FIND-CLASS TEST-DATA)) :WHERE T)))) + +(test select-dao + (with-test-connection + (dao-test-table-fixture) + (protect + (progn + (make-dao 'test-data :a "dao1") + (make-dao 'test-data :a "dao2") + (is (equal (query "select * from dao_test") + '((1 "dao1" NIL 0 0) (2 "dao2" NIL 0 0)))) + (is (equal (mapcar #'test-a (select-dao 'test-data)) + '("dao1" "dao2")))) + (execute (:drop-table 'dao-test :cascade))))) + +(test do-select-dao + (with-test-connection + (dao-test-table-fixture) + (protect + (progn + (make-dao 'test-data :a "dao1") + (make-dao 'test-data :a "dao2") + (is (equal (query "select * from dao_test") + '((1 "dao1" NIL 0 0) (2 "dao2" NIL 0 0)))) + (do-select-dao (('test-data dao)) + (progn + (setf (test-c dao) 2) + (signals error (update-dao dao)) + (with-test-connection + ;; without a new connection, this errors because the previous connection is not done + (update-dao dao)))) + (is (equal (query "select * from dao_test") + '((1 "dao1" NIL 2 0) (2 "dao2" NIL 2 0))))) + (execute (:drop-table 'dao-test :cascade))))) diff --git a/postmodern/tests/tests.lisp b/postmodern/tests/tests.lisp index 2915123..9121b3d 100644 --- a/postmodern/tests/tests.lisp +++ b/postmodern/tests/tests.lisp @@ -11,6 +11,12 @@ (fiveam:in-suite :postmodern) +(fiveam:def-suite :postmodern-base + :description "Base test suite for postmodern" + :in :postmodern) + +(fiveam:in-suite :postmodern-base) + (defun prompt-connection-to-postmodern-db-spec (param-lst) "Takes the 6 item parameter list from prompt-connection and restates it for pomo:with-connection. Note that cl-postgres does not provide the pooled connection - that is only in postmodern - so that parameter is not passed." (when (and (listp param-lst) @@ -114,7 +120,7 @@ (execute (:drop-table 'test-data))) (is (not (table-exists-p 'test-data))))) -(test prepare +(test base-prepare (with-test-connection (drop-prepared-statement "all") (when (table-exists-p 'test-data) (execute (:drop-table 'test-data))) @@ -182,7 +188,9 @@ (is (equal "select a from test_data where c = $1" (find-postgresql-prepared-statement "select1"))) (is (equal "select a from test_data where c = $1" (find-postmodern-prepared-statement "select1"))) ;; funcall now creates the new version - (is (eq :null (funcall 'select1 2))) + (if *allow-overwriting-prepared-statements* + (is (eq :null (funcall 'select1 2))) + (is (eq nil (funcall 'select1 2)))) ;; Test to ensure that we do not recreate the statement each time it is funcalled (let ((time1 (query "select prepare_time from pg_prepared_statements where name = 'select1'" :single))) (format t "Sleep 1 to allow prepare_time comparison~%") @@ -192,7 +200,9 @@ (drop-prepared-statement "select1") (signals error (funcall 'select1 2)) (defprepared select1 "select c from test_data where a = $1" :single) - (is (eq :null (funcall 'select1 2))) + (if *allow-overwriting-prepared-statements* + (is (eq :null (funcall 'select1 2))) + (is (eq :null (funcall 'select1 2)))) (drop-prepared-statement "all") (is (equal 0 (length (list-prepared-statements t)))) (is (equal 0 (length (list-postmodern-prepared-statements t)))) @@ -203,7 +213,7 @@ (is (eq :null (funcall 'select1 2))) (execute (:drop-table 'test-data))))) -(test prepare-reserved-words +(test base-prepare-reserved-words (with-test-connection (drop-prepared-statement "all") (when (table-exists-p 'from-test) (execute (:drop-table 'from-test))) @@ -216,7 +226,7 @@ (is (equal "Reykjavík" (funcall 'select1 "Seyðisfjörður"))) (execute (:drop-table 'from-test)))) -(test prepare-pooled +(test base-prepare-pooled (with-pooled-test-connection (drop-prepared-statement "all") (when (table-exists-p 'test-data) (execute (:drop-table 'test-data))) @@ -281,20 +291,30 @@ ;; Defprepared does not change the prepared statements logged in the postmodern connection or ;; in the postgresql connection. That happens at funcall. ;; Test still the original in both postgresql and postmodern - (is (equal "select a from test_data where c = $1" (find-postgresql-prepared-statement "select1"))) - (is (equal "select a from test_data where c = $1" (find-postmodern-prepared-statement "select1"))) + (is (equal "select a from test_data where c = $1" + (find-postgresql-prepared-statement "select1"))) + (is (equal "select a from test_data where c = $1" + (find-postmodern-prepared-statement "select1"))) ;; funcall now creates the new version - (is (eq :null (funcall 'select1 2))) + (if *allow-overwriting-prepared-statements* + (is (eq :null (funcall 'select1 2))) + (is (eq nil (funcall 'select1 2)))) + ;; Test to ensure that we do not recreate the statement each time it is funcalled - (let ((time1 (query "select prepare_time from pg_prepared_statements where name = 'select1'" :single))) + (let ((time1 (query "select prepare_time from pg_prepared_statements where name = 'select1'" + :single))) (format t "Sleep 1 to allow prepare_time comparison~%") (sleep 1) (funcall 'select1 2) - (is (equal time1 (query "select prepare_time from pg_prepared_statements where name = 'select1'" :single)))) + (is (equal time1 + (query "select prepare_time from pg_prepared_statements where name = 'select1'" + :single)))) (drop-prepared-statement "select1") (signals error (funcall 'select1 2)) (defprepared select1 "select c from test_data where a = $1" :single) - (is (eq :null (funcall 'select1 2))) + (if *allow-overwriting-prepared-statements* + (is (eq :null (funcall 'select1 2))) + (is (eq :null (funcall 'select1 2)))) (drop-prepared-statement "all") (is (equal 0 (length (list-prepared-statements t)))) (is (equal 0 (length (list-postmodern-prepared-statements t)))) @@ -304,7 +324,7 @@ (is (eq :null (funcall 'select1 2))) (execute (:drop-table 'test-data))))) -(test prepared-statement-over-reconnect +(test base-prepared-statement-over-reconnect (let ((terminate-backend (prepare "SELECT pg_terminate_backend($1) WHERE pg_backend_pid() = $1" @@ -379,7 +399,7 @@ (is (null rows)) (is (zerop count))))))) -(test prepared-statement-over-reconnect-pooled-1 +(test base-prepared-statement-over-reconnect-pooled-1 (with-pooled-test-connection (drop-prepared-statement "all") (let ((terminate-backend @@ -560,8 +580,10 @@ (with-logical-transaction (transaction-1) (execute (:insert-into 'test-data :set 'value 1)) (with-logical-transaction (transaction-2) - (push (lambda () (execute (:insert-into 'test-data :set 'value 3))) (commit-hooks transaction-2)) - (push (lambda () (execute (:insert-into 'test-data :set 'value 4))) (commit-hooks transaction-1)) + (push (lambda () (execute (:insert-into 'test-data :set 'value 3))) + (commit-hooks transaction-2)) + (push (lambda () (execute (:insert-into 'test-data :set 'value 4))) + (commit-hooks transaction-1)) (execute (:insert-into 'test-data :set 'value 2)))) (is (= 4 (length (query (:select '* :from 'test-data))))) (execute (:drop-table 'test-data))))) @@ -575,8 +597,10 @@ (execute (:insert-into 'test-data :set 'value 1)) (ignore-errors (with-logical-transaction (transaction-2) - (push (lambda () (execute (:insert-into 'test-data :set 'value 3))) (abort-hooks transaction-2)) - (push (lambda () (execute (:insert-into 'test-data :set 'value 4))) (abort-hooks transaction-1)) + (push (lambda () (execute (:insert-into 'test-data :set 'value 3))) + (abort-hooks transaction-2)) + (push (lambda () (execute (:insert-into 'test-data :set 'value 4))) + (abort-hooks transaction-1)) (error "no wait") (execute (:insert-into 'test-data :set 'value 2))))) (is (= 2 (length (query (:select '* :from 'test-data))))) @@ -615,29 +639,32 @@ (execute (:drop-table 'test-data)))) (test cursor - (is (equal (with-test-connection - (query (:create-table (:temp 'test-data1) ((value :type integer)))) - (loop for x from 1 to 100 do (execute (:insert-into 'test-data1 :set 'value x))) - (with-transaction () - (execute "declare test_data1_values cursor with hold for select * from test_data1") - (query "fetch forward 2 from test_data1_values"))) + (is (equal + (with-test-connection + (query (:create-table (:temp 'test-data1) ((value :type integer)))) + (loop for x from 1 to 100 do (execute (:insert-into 'test-data1 :set 'value x))) + (with-transaction () + (execute "declare test_data1_values cursor with hold for select * from test_data1") + (query "fetch forward 2 from test_data1_values"))) '((1) (2)))) - (is (equal (with-test-connection - (query (:create-table (:temp 'test-data1) ((value :type integer)))) - (loop for x from 1 to 100 do (execute (:insert-into 'test-data1 :set 'value x))) - (with-transaction () - (execute "declare test_data1_values cursor with hold for select * from test_data1") - (query "fetch forward 2 from test_data1_values")) - (query "fetch next from test_data1_values")) - '((3)))) - (is (equal (with-test-connection - (query (:create-table (:temp 'test-data1) ((value :type integer)))) - (loop for x from 1 to 100 do (execute (:insert-into 'test-data1 :set 'value x))) - (with-transaction () - (execute "declare test_data1_values cursor with hold for select * from test_data1") - (query "fetch forward 2 from test_data1_values")) - (query "fetch forward 5 from test_data1_values")) - '((3) (4) (5) (6) (7))))) + (is (equal + (with-test-connection + (query (:create-table (:temp 'test-data1) ((value :type integer)))) + (loop for x from 1 to 100 do (execute (:insert-into 'test-data1 :set 'value x))) + (with-transaction () + (execute "declare test_data1_values cursor with hold for select * from test_data1") + (query "fetch forward 2 from test_data1_values")) + (query "fetch next from test_data1_values")) + '((3)))) + (is (equal + (with-test-connection + (query (:create-table (:temp 'test-data1) ((value :type integer)))) + (loop for x from 1 to 100 do (execute (:insert-into 'test-data1 :set 'value x))) + (with-transaction () + (execute "declare test_data1_values cursor with hold for select * from test_data1") + (query "fetch forward 2 from test_data1_values")) + (query "fetch forward 5 from test_data1_values")) + '((3) (4) (5) (6) (7))))) (test notification (with-test-connection @@ -748,17 +775,21 @@ and second the string name for the datatype." "Test various index functions" (with-test-connection (pomo:drop-table 'people :if-exists t :cascade t) - (query (:create-table 'people ((id :type (or integer db-null) :primary-key :identity-by-default) (first-name :type (or (varchar 50) db-null)) + (query (:create-table 'people ((id :type (or integer db-null) :primary-key :identity-by-default) + (first-name :type (or (varchar 50) db-null)) (last-name :type (or (varchar 50) db-null))))) (query (:create-index 'idx-people-names :on 'people :fields 'last-name 'first-name)) (query (:create-index 'idx-people-first-names :on 'people :fields 'first-name)) (query (:insert-rows-into 'people :columns 'first-name 'last-name - :values '(("Eliza" "Gregory") ("Dean" "Rodgers") ("Christine" "Alvarez") ("Dennis" "Peterson") - ("Ernest" "Roberts") ("Jorge" "Wood") ("Harvey" "Strickland") ("Eugene" "Rivera") - ("Tillie" "Bell") ("Marie" "Lloyd") ("John" "Lyons") ("Lucas" "Gray") ("Edward" "May") - ("Randy" "Fields") ("Nell" "Malone") ("Jacob" "Maxwell") ("Vincent" "Adams") - ("Henrietta" "Schneider") ("Ernest" "Mendez") ("Jean" "Adams") ("Olivia" "Adams")))) + :values '(("Eliza" "Gregory") ("Dean" "Rodgers") ("Christine" "Alvarez") + ("Dennis" "Peterson") ("Ernest" "Roberts") ("Jorge" "Wood") + ("Harvey" "Strickland") ("Eugene" "Rivera") + ("Tillie" "Bell") ("Marie" "Lloyd") ("John" "Lyons") + ("Lucas" "Gray") ("Edward" "May") + ("Randy" "Fields") ("Nell" "Malone") ("Jacob" "Maxwell") + ("Vincent" "Adams") ("Henrietta" "Schneider") + ("Ernest" "Mendez") ("Jean" "Adams") ("Olivia" "Adams")))) (let ((idx-symbol (first (list-indices))) (idx-string (first (list-indices t)))) (is (pomo:index-exists-p idx-symbol)) diff --git a/postmodern/transaction.lisp b/postmodern/transaction.lisp index 1227744..61bbd38 100644 --- a/postmodern/transaction.lisp +++ b/postmodern/transaction.lisp @@ -126,7 +126,13 @@ isolation notes file in the doc folder." ,isolation-level))) (defun abort-transaction (transaction) - "Roll back the given transaction." + "Roll back the given transaction to the beginning, but the transaction +block is still active. Thus calling abort-transaction in the middle of a +transaction does not end the transaction. Any subsequent statements will still +be executed. Per the Postgresql documentation: ABORT rolls back the current +transaction and causes all the updates made by the transaction to be discarded. +This command is identical in behavior to the standard SQL command ROLLBACK, and +is present only for historical reasons." (when (transaction-open-p transaction) (let ((*database* (transaction-connection transaction))) (execute "ABORT")) diff --git a/s-sql.asd b/s-sql.asd index b520cbd..efb87da 100644 --- a/s-sql.asd +++ b/s-sql.asd @@ -9,7 +9,7 @@ :author "Marijn Haverbeke " :maintainer "Sabra Crolleton " :license "zlib" - :version "1.32.1" + :version "1.32.3" :depends-on ("cl-postgres" "alexandria") :components diff --git a/s-sql/tests/tests.lisp b/s-sql/tests/tests.lisp index f8ad0c7..a03ea7e 100644 --- a/s-sql/tests/tests.lisp +++ b/s-sql/tests/tests.lisp @@ -10,6 +10,12 @@ (fiveam:in-suite :s-sql) +(fiveam:def-suite :s-sql-base + :description "Base suite for s-sql" + :in :s-sql) + +(in-suite :s-sql-base) + (defun prompt-connection-to-s-sql-db-spec (param-lst) "Takes the 6 item parameter list from prompt-connection and restates it for pomo:with-connection. Note that cl-postgres does not provide the pooled connection - that is only in postmodern - so that parameter is not passed." (when (and (listp param-lst)