sql/relations.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id: objects.lisp 8963 2004-04-11 14:05:44Z kevin $
   5 ;;;;
   6 ;;;; Relations: This is not in CommonSQL API and may be removed
   7 ;;;;
   8 ;;;; This file is part of CLSQL.
   9 ;;;;
  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 ;;;; *************************************************************************
  14
  15 (in-package #:clsql-sys)
  16
  17
  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     (mapcar #'(lambda (sk dk)
  22                 (setf (slot-value dest dk)
  23                       (typecase sk
  24                         (symbol
  25                          (slot-value src sk))
  26                         (t sk))))
  27             skeys dkeys)))
  28
  29 (defun desynchronize-keys (dest destkey)
  30   (let ((dkeys (if (listp destkey) destkey (list destkey))))
  31     (mapcar #'(lambda (dk)
  32                 (setf (slot-value dest dk) nil))
  33             dkeys)))
  34
  35 (defmethod add-to-relation ((target standard-db-object)
  36                             slot-name
  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 (equal (type-of value) join-class)
  47       (error 'clsql-type-error :slotname slot-name :typespec join-class
  48              :value value))
  49     (when (gethash :target-slot dbinfo)
  50       (error "add-to-relation does not work with many-to-many relations yet."))
  51     (if to-many
  52         (progn
  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))))
  59         (progn
  60           (synchronize-keys value foreignkey target homekey)
  61           (setf (slot-value target slot-name) value)))))
  62
  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."))
  73     (if to-many
  74         (progn
  75           (desynchronize-keys value foreignkey)
  76           (if (slot-boundp target slot-name)
  77               (setf (slot-value target slot-name)
  78                     (remove value
  79                             (slot-value target slot-name)
  80                             :test #'equal))))
  81         (progn
  82           (desynchronize-keys target homekey)
  83           (setf (slot-value target slot-name)
  84                 nil)))))
  85