1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
4 ;;;; $Id: objects.lisp 8963 2004-04-11 14:05:44Z kevin $
6 ;;;; Relations: This is not in CommonSQL API and may be removed
8 ;;;; This file is part of CLSQL.
10 ;;;; CLSQL users are granted the rights to distribute and use this software
11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
13 ;;;; *************************************************************************
18 (defun synchronize-keys (src srckey dest destkey)
19 (let ((skeys (if (listp srckey) srckey (list srckey)))
20 (dkeys (if (listp destkey) destkey (list destkey))))
21 (mapc #'(lambda (sk dk)
22 (setf (slot-value dest dk)
29 (defun desynchronize-keys (dest destkey)
30 (let ((dkeys (if (listp destkey) destkey (list destkey))))
32 (setf (slot-value dest dk) nil))
35 (defmethod add-to-relation ((target standard-db-object)
37 (value standard-db-object))
38 (let* ((objclass (class-of target))
39 (sdef (or (slotdef-for-slot-with-class slot-name objclass)
40 (error "~s is not an known slot on ~s" slot-name target)))
41 (dbinfo (view-class-slot-db-info sdef))
42 (join-class (gethash :join-class dbinfo))
43 (homekey (gethash :home-key dbinfo))
44 (foreignkey (gethash :foreign-key dbinfo))
45 (to-many (gethash :set dbinfo)))
46 (unless (subtypep (type-of value) join-class)
47 (error 'clsql-type-error :slotname slot-name :typespec join-class
49 (when (gethash :target-slot dbinfo)
50 (error "add-to-relation does not work with many-to-many relations yet."))
53 (synchronize-keys target homekey value foreignkey)
54 (if (slot-boundp target slot-name)
55 (unless (member value (slot-value target slot-name))
56 (setf (slot-value target slot-name)
57 (append (slot-value target slot-name) (list value))))
58 (setf (slot-value target slot-name) (list value))))
60 (synchronize-keys value foreignkey target homekey)
61 (setf (slot-value target slot-name) value)))))
63 (defmethod remove-from-relation ((target standard-db-object)
64 slot-name (value standard-db-object))
65 (let* ((objclass (class-of target))
66 (sdef (slotdef-for-slot-with-class slot-name objclass))
67 (dbinfo (view-class-slot-db-info sdef))
68 (homekey (gethash :home-key dbinfo))
69 (foreignkey (gethash :foreign-key dbinfo))
70 (to-many (gethash :set dbinfo)))
71 (when (gethash :target-slot dbinfo)
72 (error "remove-relation does not work with many-to-many relations yet."))
75 (desynchronize-keys value foreignkey)
76 (if (slot-boundp target slot-name)
77 (setf (slot-value target slot-name)
79 (slot-value target slot-name)
82 (desynchronize-keys target homekey)
83 (setf (slot-value target slot-name)