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

named relations

darcs-hash:ff47198fff6dcc4b3ec48de5b0d9cbfc75c82f22
parent b572391c
......@@ -169,51 +169,88 @@ relation with OBJECT.")
;; User is responsible for SETFing relation pseudo-accessor to NIL or
;; periodically cleaning up relation class with slots of value NIL."
(defmacro def-many-to-many (class1-name class2-name connection-spec)
"Defines many-to-many mapping between two persistent classes.
(defmacro def-many-to-many (class1-name class2-name &key connection-spec name)
"Defines a possibly named many-to-many mapping between two
persistent classes. There can be only one unnamed mapping between any
two classes, and any number of named mappings. CLASS*-NAME should be
an \(unquoted\) symbol with class name.
CLASS*-NAME should be an (unquoted) symbol with class name.
Defines additional mapping persistent class `NAME' \(if `NAME' is
not provided, `CLASS1-NAME-CLASS2-NAME' is used\), and for each of
classes, a method that retrieves list of instances of second class
\(named like that class or, if the relation is named,
CLASS-NAME-IN-NAME. Mapping class has three slots, `CLASS1-NAME' and
`CLASS2-NAME' that hold instances of first and second class, and
`WEIGHT' that holds an integer representing the strength of the
relationship. The following functions are available:
Defines additional mapping persistent class `CLASS1-NAME-CLASS2-NAME'
and for each of classes, a method that retrieves list of instances of
second class. Mapping class has two slots, named `CLASS1-NAME' and
`CLASS2-NAME' that hold instances of first and second class.
* A predicate `RELATEDP', taking a keyword argument `RELATION', which
tells whether two objects are in a relation \(if `RELATION' is not
provided, the unnamed relation is assumed\). It returns a `NAME' or
`CLASS1-NAME-CLASS2-NAME' object. It has an accessor `WEIGHT'.
The connection-spec specifies the connection to be used with the link table."
(let ((table-name (intern (format nil "~A-~A" class1-name class2-name)))
* A function `RELATE' \(`RELATE-IN-NAME'\) that establishes a
relationship between its two arguments. It takes a key-argument,
`WEIGHT', by default 1. The order in which the object arguments are
provided is irrelevant. `CONNECTION-SPEC' specifies the connection to
be used to create the link table."
(let ((table-name (or name (intern (format nil "~A-~A" class1-name class2-name))))
(class1-method-name class2-name)
(class2-method-name class1-name))
`(progn
(defclass ,table-name (dao)
((,class1-name :type ,class1-name :accessor ,class1-name :foreign t :on-delete :cascade)
(,class2-name :type ,class2-name :accessor ,class2-name :foreign t :on-delete :cascade))
(,class2-name :type ,class2-name :accessor ,class2-name :foreign t :on-delete :cascade)
(weight :type integer :accessor weight-of :initform 1 :initarg :weight))
;; A unique constraint here
;; or better no: thing of tags.
(:unique (,class1-name ,class2-name))
(:connection-spec ,@connection-spec)
(:metaclass db-class))
(defmethod ,class1-method-name ((object ,class1-name))
(mapcar #',class2-name (select-dao-fun ',table-name (list := ',class1-name (get-id object)))))
(defmethod ,class2-method-name ((object ,class2-name))
(mapcar #',class1-name (select-dao-fun ',table-name (list := ',class2-name (get-id object)))))
(defmethod relatedp ((object1 ,class1-name) (object2 ,class2-name))
(defmethod relatedp-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null)))
(select-dao-fun ',table-name `(and
(:= ,',class1-name ,(get-id object1))
(:= ,',class2-name ,(get-id object2)))))
(defmethod unrelate ((object1 ,class1-name) (object2 ,class2-name))
(delete-dao (car (relatedp object1 object2)))))))
(defgeneric relate (object1 object2)
(:documentation "Make OBJECT1 and OBJECT2 enter into a many to many relation.")
(:method ((object1 dao) (object2 dao))
;; Catch unique constraint violation
(let* ((type1 (type-of object1))
(type2 (type-of object2))
(link (intern (format nil "~A-~A" type1 type2)))
(instance (make-instance link)))
(progn
(setf (slot-value instance type1) object1)
(setf (slot-value instance type2) object2)
(save-dao instance)))))
(defmethod relate-method
((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null)) weight)
(let ((instance (make-instance ',table-name :weight weight)))
(setf (slot-value instance ',class1-name) object1)
(setf (slot-value instance ',class2-name) object2)
(save-dao instance)))
(defmethod relate-method ((object1 ,class2-name) (object2 ,class1-name) relation weight)
(relate-method object2 object1 relation weight))
(defmethod unrelate-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null)))
(delete-dao (car (relatedp object1 object2))))
(defmethod unrelate-method ((object2 ,class2-name) (object1 ,class1-name) relation)
(unrelate-method object1 object2 relation)))))
(defgeneric relate-method (object1 object2 relation weight)
(:documentation "Relate `OBJECT1' with `OBJECT2' in `RELATION'."))
(defgeneric relatedp-method (object1 object2 relation)
(:documentation "Tell if `OBJECT1' is related to `OBJECT2' in `RELATION'."))
(defgeneric unrelate-method (object1 object2 relation)
(:documentation "`OBJECT1' stops being with `OBJECT2' in `RELATION'."))
(defun relate (object1 object2 &key relation (weight 1))
"Make OBJECT1 and OBJECT2 enter into the many-to-many relation
`RELATION'. If `RELATION' is not provided, the unnamed relation is
assumed."
(relate-method object1 object2 relation weight))
(defun relatedp (object1 object2 &key relation)
"Tell whether `OBJECT1' and `OBJECT2' are in the many-to-many relation
`RELATION' \(or the unnamed relation if `RELATION' is not provided\)."
(relatedp-method object1 object2 relation))
(defun unrelate (object1 object2 &key relation)
"`OBJECT1' stops being with `OBJECT2' in `RELATION'."
(unrelate-method object1 object2 relation))
(defmacro make-and-save (type &rest rest)
"Make a DAO and immediately save it. Takes the same arguments as
......
Supports Markdown
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