Commit 23674ba1 authored by ryszard.szopa's avatar ryszard.szopa
Browse files

db-class can have multislot unique constraints.

parent 25b23bbe
......@@ -77,7 +77,8 @@ be reverted.)"
(warn "Table ~A already exists." (class-name class)))
(error err))))
; here should be some code dropping constraints that are not necessary
(apply-foreign-key-constraints class)))
(apply-foreign-key-constraints class)
(apply-unique-constraints class)))
(defmethod create-table ((name symbol))
(let ((class (find-class name)))
......@@ -106,6 +107,18 @@ be reverted.)"
(format nil "UNIQUE ~A"
(sql-ize (slot-definition-name slot))))
(defmethod add-constraint ((list list) (constraint (eql :unique)))
(assert (every (lambda (x)
(typep x 'db-class-slot-definition)) list))
(let ((class (slot-value (car list) 'sb-pcl::allocation-class)))
(with-class-connection (class)
(postmodern:execute (format nil "ALTER TABLE ~A ADD UNIQUE (~A~{, ~A~});"
(sql-ize (class-name class))
(sql-ize (slot-definition-name (car list)))
(mapcar #'(lambda (x)
(sql-ize (slot-definition-name x))) (cdr list)))))))
(defmethod apply-foreign-key-constraints ((class db-class))
(iter (for slot in (db-class-foreign-keys class))
(let ((closure (lambda ()
......@@ -32,6 +32,7 @@ wrong with its SQL counterpart.")))
(defmetaclass db-class (standard-class)
((indices :initarg :indices :initform () :reader db-class-indices)
(unique :initarg :unique :initform () :reader db-class-unique)
;; TODO: Additional slot, CONSTRAINTS.
(connection-spec :initarg :connection-spec :initform nil :reader db-class-connection-spec)
......@@ -100,7 +101,9 @@ metaclass set to DB-CLASS."
(when (foreign-type-p slot)
(push slot (db-class-foreign-keys class)))
(when (unique slot)
(push slot (db-class-unique-keys class)))))
(push slot (db-class-unique-keys class))))
(iter (for constraint in (db-class-unique class))
(push (mapcar (lambda (x) (get-slot-by-name class x)) constraint) (db-class-unique-keys class))))
(defgeneric remove-finished-classes (class)
(:documentation "Remove classes that are already finished from UNFINISHED-CLASSES of CLASS.")
......@@ -270,6 +270,17 @@ metaclass set to HTML and the right connection-spec."
(is (null (select-dao 'some-long-name))))
(db-test (unique-constraints :depends-on dao-definition)
(finishes (defdao-example cinco ()
((foo :type integer :accessor foo :initarg :foo)
(bar :type integer :accessor bar :initarg :bar ))
(:unique (foo bar))))
(make-and-save 'cinco :foo 1 :bar 1)
(finishes (make-and-save 'cinco :foo 1 :bar 2))
(finishes (make-and-save 'cinco :foo 2 :bar 1))
(signals cl-postgres:database-error (make-and-save 'cinco :foo 1 :bar 1)))
;;; Copyright (C) 2007
;;; Ryszard Szopa <> &
;;; Streamtech
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