r8971: add missing file

diff --git a/ChangeLog b/ChangeLog
index 0ef29d1ea432c0611806790d1521dd054cf79427..c095a50308ae5829f9f4b2e2c820407058c9d8e0 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+12 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
+       * Version 2.6.5
+       * sql/relations.lisp: Add missing file
+       * utils/time.lisp: Fixes/extensions [Marcus Pearce]
+       * test/test-time.lips: New file [Marcus Pearce]
+       
 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.6.4
        * test/test-init.lisp: Properly handle object
@@ -5,7 +11,7 @@
        * sql/sql.lisp: Make DESCRIBE-TABLE a generic
        function so can have methods specialized on
        table being a string or an sql-table object.
-       * base/pool.lisp: Really CMUCL locking
+       * base/pool.lisp: Really fix CMUCL locking
        
 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
        * Version 2.6.3

diff --git a/sql/relations.lisp b/sql/relations.lisp
new file mode 100644 (file)
index 0000000..4497122
--- /dev/null
+++ b/sql/relations.lisp
@@ -0,0 +1,85 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;;
+;;;; $Id: objects.lisp 8963 2004-04-11 14:05:44Z kevin $
+;;;;
+;;;; Relations: This is not in CommonSQL API and may be removed
+;;;;
+;;;; This file is part of CLSQL.
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package #:clsql-sys)
+
+
+(defun synchronize-keys (src srckey dest destkey)
+  (let ((skeys (if (listp srckey) srckey (list srckey)))
+       (dkeys (if (listp destkey) destkey (list destkey))))
+    (mapcar #'(lambda (sk dk)
+               (setf (slot-value dest dk)
+                     (typecase sk
+                       (symbol
+                        (slot-value src sk))
+                       (t sk))))
+           skeys dkeys)))
+
+(defun desynchronize-keys (dest destkey)
+  (let ((dkeys (if (listp destkey) destkey (list destkey))))
+    (mapcar #'(lambda (dk)
+               (setf (slot-value dest dk) nil))
+           dkeys)))
+
+(defmethod add-to-relation ((target standard-db-object)
+                           slot-name
+                           (value standard-db-object))
+  (let* ((objclass (class-of target))
+        (sdef (or (slotdef-for-slot-with-class slot-name objclass)
+                   (error "~s is not an known slot on ~s" slot-name target)))
+        (dbinfo (view-class-slot-db-info sdef))
+        (join-class (gethash :join-class dbinfo))
+        (homekey (gethash :home-key dbinfo))
+        (foreignkey (gethash :foreign-key dbinfo))
+        (to-many (gethash :set dbinfo)))
+    (unless (equal (type-of value) join-class)
+      (error 'clsql-type-error :slotname slot-name :typespec join-class
+             :value value))
+    (when (gethash :target-slot dbinfo)
+      (error "add-to-relation does not work with many-to-many relations yet."))
+    (if to-many
+       (progn
+         (synchronize-keys target homekey value foreignkey)
+         (if (slot-boundp target slot-name)
+              (unless (member value (slot-value target slot-name))
+                (setf (slot-value target slot-name)
+                      (append (slot-value target slot-name) (list value))))
+              (setf (slot-value target slot-name) (list value))))
+        (progn
+          (synchronize-keys value foreignkey target homekey)
+          (setf (slot-value target slot-name) value)))))
+
+(defmethod remove-from-relation ((target standard-db-object)
+                           slot-name (value standard-db-object))
+  (let* ((objclass (class-of target))
+        (sdef (slotdef-for-slot-with-class slot-name objclass))
+        (dbinfo (view-class-slot-db-info sdef))
+        (homekey (gethash :home-key dbinfo))
+        (foreignkey (gethash :foreign-key dbinfo))
+        (to-many (gethash :set dbinfo)))
+    (when (gethash :target-slot dbinfo)
+      (error "remove-relation does not work with many-to-many relations yet."))
+    (if to-many
+       (progn
+         (desynchronize-keys value foreignkey)
+         (if (slot-boundp target slot-name)
+             (setf (slot-value target slot-name)
+                   (remove value
+                           (slot-value target slot-name)
+                            :test #'equal))))
+        (progn
+          (desynchronize-keys target homekey)
+          (setf (slot-value target slot-name)
+                nil)))))
+