[patch] Updated Patch for fault-join-target-slot and update-objects-joins
Drew Crampsie <[email protected]> Thu, 27 Oct 2005 19:15:57 -0700
| Newsgroups | gmane.lisp.clsql.devel |
|---|---|
| Message-ID | <[email protected]> |
Attached is an updated version of my previous patch which also fixes the problems with update-objects-joins when using the :target-slot attribute. Both these problems were described by Aleksandar Bakic earlier this month on this list, and AFAICT this patch is what was needed. drewc Drew Crampsie wrote: > I was trying to use the target-slot attribute, but noticed that it did > not work if the slot name differed from the name of the class it > pointing to. > > In other words, the code neglected to find the :join-class in the target > slot definition, rather just assuming that the slot name also named the > class. This broke for my purposes. > > I have included a patch that fixes this, and can provide an example of > the code that broke with the original behaviour if my explanation was > not clear enough (it's late and i'm tired). > > cheers, > > drewc > > > ------------------------------------------------------------------------ > > --- sql/oodml.lisp 2005-09-17 17:13:12.000000000 -0700 > +++ /home/drewc/oodml.lisp 2005-10-26 20:59:27.491098112 -0700 > @@ -627,21 +627,23 @@ > > (defun fault-join-target-slot (class object slot-def) > (let* ((dbi (view-class-slot-db-info slot-def)) > - (ts (gethash :target-slot dbi)) > - (jc (gethash :join-class dbi)) > - (ts-view-table (view-table (find-class ts))) > + (ts (gethash :target-slot dbi)) > + (jc (gethash :join-class dbi)) > (jc-view-table (view-table (find-class jc))) > (tdbi (view-class-slot-db-info > - (find ts (class-slots (find-class jc)) > - :key #'slot-definition-name))) > + (find ts (class-slots (find-class jc)) > + :key #'slot-definition-name))) > (retrieval (gethash :retrieval tdbi)) > + (tsc (gethash :join-class tdbi)) > + (ts-view-table (view-table (find-class tsc))) > (jq (join-qualifier class object slot-def)) > (key (slot-value object (gethash :home-key dbi)))) > + > (when jq > (ecase retrieval > (:immediate > (let ((res > - (find-all (list ts) > + (find-all (list tsc) > :inner-join (sql-expression :table jc-view-table) > :on (sql-operation > '== > @@ -667,7 +669,7 @@ > ;; just fill in minimal slots > (mapcar > #'(lambda (k) > - (let ((instance (make-instance ts :view-database (view-database object))) > + (let ((instance (make-instance tsc :view-database (view-database object))) > (jcc (make-instance jc :view-database (view-database object))) > (fk (car k))) > (setf (slot-value instance (gethash :home-key tdbi)) fk) > > > ------------------------------------------------------------------------ > > _______________________________________________ > CLSQL-Devel mailing list > [email protected] > http://lists.b9.com/mailman/listinfo/clsql-devel _______________________________________________ CLSQL-Devel mailing list [email protected] http://lists.b9.com/mailman/listinfo/clsql-devel
oodml2.patch
(text/plain, 3 KB)
--- sql/oodml.lisp 2005-09-17 17:13:12.000000000 -0700
+++ /home/drewc/oodml.lisp 2005-10-27 01:50:00.440886912 -0700
@@ -627,21 +627,23 @@
(defun fault-join-target-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
- (ts (gethash :target-slot dbi))
- (jc (gethash :join-class dbi))
- (ts-view-table (view-table (find-class ts)))
+ (ts (gethash :target-slot dbi))
+ (jc (gethash :join-class dbi))
(jc-view-table (view-table (find-class jc)))
- (tdbi (view-class-slot-db-info
- (find ts (class-slots (find-class jc))
- :key #'slot-definition-name)))
+ (tdbi (view-class-slot-db-info
+ (find ts (class-slots (find-class jc))
+ :key #'slot-definition-name)))
(retrieval (gethash :retrieval tdbi))
+ (tsc (gethash :join-class tdbi))
+ (ts-view-table (view-table (find-class tsc)))
(jq (join-qualifier class object slot-def))
(key (slot-value object (gethash :home-key dbi))))
+
(when jq
(ecase retrieval
(:immediate
(let ((res
- (find-all (list ts)
+ (find-all (list tsc)
:inner-join (sql-expression :table jc-view-table)
:on (sql-operation
'==
@@ -667,7 +669,7 @@
;; just fill in minimal slots
(mapcar
#'(lambda (k)
- (let ((instance (make-instance ts :view-database (view-database object)))
+ (let ((instance (make-instance tsc :view-database (view-database object)))
(jcc (make-instance jc :view-database (view-database object)))
(fk (car k)))
(setf (slot-value instance (gethash :home-key tdbi)) fk)
@@ -742,24 +744,30 @@
(let* ((keys (if max-len
(subseq object-keys i (min (+ i query-len) n-object-keys))
object-keys))
- (results (find-all (list (gethash :join-class dbi))
- :where (make-instance 'sql-relational-exp
- :operator 'in
- :sub-expressions (list (sql-expression :attribute foreign-key)
- keys))
- :result-types :auto
- :flatp t)))
+ (results (unless (gethash :target-slot dbi)
+ (find-all (list (gethash :join-class dbi))
+ :where (make-instance 'sql-relational-exp
+ :operator 'in
+ :sub-expressions (list (sql-expression :attribute foreign-key)
+ keys))
+ :result-types :auto
+ :flatp t)) ))
(dolist (object objects)
(when (or force-p (not (slot-boundp object slotdef-name)))
- (let ((res (remove-if-not #'(lambda (obj)
- (equal obj (slot-value
- object
- home-key)))
- results
- :key #'(lambda (res)
- (slot-value res
- foreign-key)))))
+ (let ((res (if results
+ (remove-if-not #'(lambda (obj)
+ (equal obj (slot-value
+ object
+ home-key)))
+ results
+ :key #'(lambda (res)
+ (slot-value res
+ foreign-key)))
+
+ (progn
+ (when (gethash :target-slot dbi)
+ (fault-join-target-slot class object slotdef))))))
(when res
(setf (slot-value object slotdef-name)
(if (gethash :set dbi) res (car res)))))))))))))