Commit c01c9628 authored by ryszard.szopa's avatar ryszard.szopa
Browse files

with-object-connection

Former WITH-CLASS-CONNECTION becomes, more appropriately,
WITH-OBJECT-CONNECTION. New macro WITH-CLASS-CONNECTION starts a
connection absing on a provided class.

darcs-hash:3e17b17e55213a176a08371edf62097ae96e3c64
parent d8074236
......@@ -33,7 +33,7 @@
(:documentation "Return a boolean indicating whether the given DAO
exists in the database.")
(:method ((dao dao))
(with-class-connection (dao)
(with-object-connection (dao)
(and (slot-boundp dao 'id)
(postmodern::query (:select (:exists (:select 1 :from (class-name-of dao) :where (:= 'id (get-id dao)))))
:single)))))
......@@ -48,7 +48,7 @@ exists in the database.")
(defgeneric insert-dao (dao)
(:documentation "Insert the given dao into the database.")
(:method ((dao dao))
(with-class-connection (dao)
(with-object-connection (dao)
(unless (slot-boundp dao 'id)
(setf (slot-value dao 'id) (postmodern::sequence-next (id-seq-name (class-of dao)))))
(postmodern::execute (sql-compile `(:insert-into ,(class-name-of dao) :set ,@(set-fields dao)))))))
......@@ -58,7 +58,7 @@ exists in the database.")
with the values in the given object."))
(defmethod update-dao ((dao dao))
(with-class-connection (dao)
(with-object-connection (dao)
(postmodern::execute (sql-compile
`(:update ,(class-name-of dao) :set ,@(set-fields dao)
:where (:= 'id (get-id dao)))))))
......@@ -73,7 +73,7 @@ with the database."
(iter
(for slot in (non-transient-slots-of dao))
(let ((value-from-db (with-class-connection (dao)
(let ((value-from-db (with-object-connection (dao)
(postmodern::query
(:select (slot-definition-name slot)
:from (class-name-of dao)
......
......@@ -17,60 +17,59 @@ names is used."))
(defmethod create-table ((class db-class))
(unless (class-finalized-p class)
(error "The class is not finalized."))
(with-connection-fun (db-class-connection-spec class)
(lambda ()
(handler-case
(let ((class-name (class-name class)))
(labels ((index-name (fields)
(format nil "~A~{_~A~}_index" (to-sql-name class-name) (mapcar #'to-sql-name fields)))
(type-and-reference (slot)
(if (foreign-type-p slot)
(list :type 'integer :references (list (list (slot-definition-type slot) 'id) :cascade)) ;is this cascade ok?
`(:type ,(slot-definition-type slot)))))
(postmodern:execute
(sql-compile
`(:create-table ,class-name
,(iter (for slot in (class-non-transient-slots class))
(collect
(cons (slot-definition-name slot) (type-and-reference slot))))
(:primary-key id)))) ;id is hardcoded as a primary key
(dolist (index (mapcar (lambda (x) (if (consp x) x (list x)))(db-class-indices class)))
(postmodern:execute (sql-compile `(:create-index (:raw ,(index-name index))
:on ,class-name
:fields ,@index))))
(postmodern:execute (:create-sequence (id-seq-name class)))))
(database-error (err)
(if (string= (database-error-code err) "42P07") ;table already exists
(progn
(postmodern:with-transaction ()
;; FIXME: This may be considered as a quick
;; hack. S-SQL should be changed to support ALTER
;; commands.
(handler-case
(database-consistent-with-specification class)
(sql-column-does-not-exist (err)
(restart-case (error err)
(fix-it () :report "Add the column to the
table. (Note that all the changes for one table are done in a
(with-class-connection (class)
(handler-case
(let ((class-name (class-name class)))
(labels ((index-name (fields)
(format nil "~A~{_~A~}_index" (to-sql-name class-name) (mapcar #'to-sql-name fields)))
(type-and-reference (slot)
(if (foreign-type-p slot)
(list :type 'integer :references (list (list (slot-definition-type slot) 'id) :cascade)) ;is this cascade ok?
`(:type ,(slot-definition-type slot)))))
(postmodern:execute
(sql-compile
`(:create-table ,class-name
,(iter (for slot in (class-non-transient-slots class))
(collect
(cons (slot-definition-name slot) (type-and-reference slot))))
(:primary-key id)))) ;id is hardcoded as a primary key
(dolist (index (mapcar (lambda (x) (if (consp x) x (list x)))(db-class-indices class)))
(postmodern:execute (sql-compile `(:create-index (:raw ,(index-name index))
:on ,class-name
:fields ,@index))))
(postmodern:execute (:create-sequence (id-seq-name class)))))
(database-error (err)
(if (string= (database-error-code err) "42P07") ;table already exists
(progn
(postmodern:with-transaction ()
;; FIXME: This may be considered as a quick
;; hack. S-SQL should be changed to support ALTER
;; commands.
(handler-case
(database-consistent-with-specification class)
(sql-column-does-not-exist (err)
(restart-case (error err)
(fix-it () :report "Add the column to the
table. (Note that allocate-instance the changes for one table are done in a
transaction, so if at any time you choose abort the changes will be
reverted.)"
(postmodern:execute (format nil "ALTER TABLE ~A ADD COLUMN ~A ~A;"
(table-name err) (column-name err) (column-type err))))
(ignore () ())))
(sql-column-error (err)
(restart-case (error err)
(fix-it () :report "Alter the type of the
(postmodern:execute (format nil "ALTER TABLE ~A ADD COLUMN ~A ~A;"
(table-name err) (column-name err) (column-type err))))
(ignore () ())))
(sql-column-error (err)
(restart-case (error err)
(fix-it () :report "Alter the type of the
column. (Note that all the changes for one table are done in a
transaction, so if at any time you choose abort the changes will be
reverted."
(postmodern:execute (format nil "ALTER TABLE ~A ALTER COLUMN ~A TYPE ~A"
(table-name err) (column-name err) (needed-type err))))
(ignore () ())))))
(warn "Table ~A already exists." (class-name class)))
(error err)))))))
(postmodern:execute (format nil "ALTER TABLE ~A ALTER COLUMN ~A TYPE ~A"
(table-name err) (column-name err) (needed-type err))))
(ignore () ())))))
(warn "Table ~A already exists." (class-name class)))
(error err))))))
(defmethod create-table ((name symbol))
(let ((class (find-class name)))
......
......@@ -42,14 +42,26 @@
`(with-connection-fun '(,database ,user ,password ,host :port ,port :pooled-p ,pooled-p)
(lambda () (progn ,@body))))
(defun with-class-connection-fun (object what-to-do)
"Functional interface to the macro WITH-CLASS-CONNECTION."
(defun with-object-connection-fun (object what-to-do)
"Functional interface to the macro WITH-OBJECT-CONNECTION."
(with-connection-fun (db-class-connection-spec (class-of object))
what-to-do))
(defmacro with-class-connection ((object) &body body)
(defmacro with-object-connection ((object) &body body)
"Run BODY in an environment with a connection to the database
specified by the DB-CLASS-CONNECTION-SPEC of the class of OBJECT."
`(with-class-connection-fun ,object
`(with-object-connection-fun ,object
(lambda () (progn ,@body))))
(defun with-class-connection-fun (class what-to-do)
"Functional interface to the macro WITH-CLASS-CONNECTION."
(with-connection-fun (db-class-connection-spec class)
what-to-do))
(defmacro with-class-connection ((class) &body body)
"Run BODY in an environment with a connection to the database
specified by the DB-CLASS-CONNECTION-SPEC of CLASS."
`(with-class-connection-fun ,class
(lambda () (progn ,@body))))
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment