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

with-class-connection

darcs-hash:36037370b4fb3e46a634a4181bfd809ca23069a0
parent 1adf1ba2
......@@ -17,58 +17,60 @@ names is used."))
(defmethod create-table ((class db-class))
(unless (class-finalized-p class)
(error "The class is not finalized."))
(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
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
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)))))
(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
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
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)))))))
(defmethod create-table ((name symbol))
(let ((class (find-class name)))
......@@ -92,8 +94,10 @@ right name in the table, but its type is wrong"))
(:documentation "Condition signaling a missing column in an existing table."))
(defgeneric database-consistent-with-specification (class)
(:documentation "Return nothing if TABLE in the connected-p database meets its
specification. Otherwise, throw an appropriate error.")
(:documentation "Return nothing if TABLE in the connected-p database
meets its specification. Otherwise, throw an appropriate error. There
must exist a connection to the DATABASE in order to run this
function.")
(:method ((class db-class))
(let ((class-name (class-name class)))
(labels
......
......@@ -9,7 +9,8 @@
;;
(defclass db-class (standard-class)
((indices :initarg :indices :initform () :reader db-class-indices)))
((indices :initarg :indices :initform () :reader db-class-indices)
(connection-spec :initarg :connection-spec :reader db-class-connection-spec)))
(defmethod validate-superclass ((class db-class)
(superclass standard-class))
......
......@@ -27,4 +27,26 @@
"SLOT-VALUE if SLOT in OBJECT is not foreign, the ID of the object in the slot otherwise."
(let ((value (slot-value object slot)))
(or (and (typep value 'dao) (get-id value))
value)))
\ No newline at end of file
value)))
(defun with-connection-fun (connection-spec what-to-do)
"Functional interface to the macro WITH-CONNECTION."
(let ((postmodern:*database* (apply #'postmodern:connect connection-spec)))
(unwind-protect (progn (funcall what-to-do))
(postmodern:disconnect postmodern:*database*))))
;; This is postmodern's WITH-CONNECTION modified to use the functional
;; interface. Maybe it should be added to postmodern.
(defmacro with-connection ((database user password host &key (port 5432) pooled-p) &body body)
"Binds *database* to a new connection and runs body in that scope."
`(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)
(with-connection-fun (car (db-class-connection-spec object))
(funcall what-to-do)))
(defmacro with-class-connection ((object) &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 (car (db-class-connection-spec (class-of ,object)))
(lambda () (progn ,@body))))
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