[Factor foreign relation slot code clinton@unknownlamer.org**20101026200654 Ignore-this: 66526a01050461e5a8e5ed5aeb6f63c4 * Pending changes are properly applied when reloading relation slots * UPDATE and DELETE operations work for non-persistent instances ] { hunk ./src/db-access-class.lisp 115 -(defun apply-pending-foreign-operations (object slotd relations) - "Performs any pending foreign operations on SLOTD when reloading a -slot after calling FOREIGN-RELATIONS-MAKUNOUND" - (if-bind pending-operations (reverse - (remove slotd (slot-value object - '%foreign-modifications) - :test-not #'eql - :key #'fm-slotd)) - (progn - (dolist (op pending-operations) - (setf relations - (ecase (fm-operation op) - ((:foreign-insert) (pushnew (fm-instance op) relations)) - ((:foreign-update) (nsubst-if (fm-instance op) - (lambda (i) (db= op i)) - relations)) - ((:foreign-delete) (delete (fm-instance op) - relations - :test #'db=))))) - - relations) - relations)) +(defgeneric find-foreign-relations (class object slotd)) hunk ./src/db-access-class.lisp 117 -(defun find-foreign-relations (class object slotd) +(defmethod find-foreign-relations ((class db-access-class) object slotd) hunk ./src/db-access-class.lisp 121 - (apply-pending-foreign-operations - object - slotd - (select-objects (slot-definition-foreign-relation slotd) - :where `(:= ,(or (slot-definition-foreign-join-spec slotd) - (class-id-column-name class)) - ,(slot-value object (class-id-column-name class))))))) + (select-objects (slot-definition-foreign-relation slotd) + :where `(:= ,(or (slot-definition-foreign-join-spec slotd) + (class-id-column-name class)) + ,(slot-value object (class-id-column-name class)))))) hunk ./src/foreign-relation-slots.lisp 8 +;;; Objects stored within %foreign-modifications +;;; :insert is always non-persistent +;;; :update is always persistent +;;; :delete is always persistant + hunk ./src/foreign-relation-slots.lisp 55 +(defun foreign-slot-insert! (slotval foreign-dao) + (pushnew foreign-dao slotval)) + +(flet ((recklessly-db= (dao1 dao2) + (if (and (persistentp dao1) (persistentp dao2)) + (db= dao1 dao2) + (eql dao1 dao2)))) + + ;; binding obsolete-dao to foreign-dao by default allows code to be + ;; shared with apply-pending-foreign-updates: the db= comparison + ;; will always be taken when called from there which will perform + ;; the expected operation + (defun foreign-slot-update! (slotval foreign-dao &optional (obsolete-dao foreign-dao)) + (nsubst foreign-dao obsolete-dao + slotval + :test #'recklessly-db=)) + + (defun foreign-slot-delete! (slotval foreign-dao) + (delete foreign-dao slotval + :test #'recklessly-db=))) + hunk ./src/foreign-relation-slots.lisp 94 - (pushnew foreign-dao (slot-value dao (slot-definition-name slotd)))) + (foreign-slot-insert! (slot-value dao (slot-definition-name slotd)) + foreign-dao)) hunk ./src/foreign-relation-slots.lisp 119 - (nsubst foreign-dao obsolete-dao - (slot-value dao (slot-definition-name slotd)))) + (foreign-slot-update! + (slot-value dao (slot-definition-name slotd)) + foreign-dao obsolete-dao)) hunk ./src/foreign-relation-slots.lisp 149 - (assert (and (persistentp dao) - (persistentp foreign-dao) - (table-name-compatible-with-slot slotd foreign-dao)) + (assert (table-name-compatible-with-slot slotd foreign-dao) hunk ./src/foreign-relation-slots.lisp 151 - "Dragons: ~A ~A ~A" dao slotd foreign-dao) + "Table name incompatible with slot: ~A ~A ~A" dao slotd foreign-dao) hunk ./src/foreign-relation-slots.lisp 155 - (pushnew (make-foreign-modification - :operation :foreign-delete - :instance foreign-dao - :slotd slotd) - %fm :test #'equal) - (setf (slot-value dao (slot-definition-name slotd)) - (delete foreign-dao (slot-value dao (slot-definition-name slotd)) - :test (lambda (dao1 dao2) - (ignore-errors (db= dao1 dao2))))))) + (cond ((persistentp foreign-dao) + (assert (persistentp dao) + (dao) + "Cannot delete persistent foreign reference ~A to non-persistent object ~A" + foreign-dao dao) + (if (find foreign-dao + (slot-value dao (slot-definition-name slotd)) + :test (lambda (dao1 dao2) + (ignore-errors (db= dao1 dao2)))) + (prog1 (setf (slot-value dao (slot-definition-name slotd)) + (foreign-slot-delete! + (slot-value dao (slot-definition-name slotd)) + foreign-dao)) + (pushnew (make-foreign-modification + :operation :foreign-delete + :instance foreign-dao + :slotd slotd) + %fm :test #'equal)) + (error "foreign-dao not found"))) + ((not (persistentp foreign-dao)) + ;; Remove the insert operation rather than leaving + ;; operations to insert/delete on reload (simplifies other + ;; code -- reload can assume all :delete operations are + ;; persistent instances) + (if-bind inserted-fm-op + (find foreign-dao %fm + :test (lambda (o maybe-insert) + (when (eq (fm-operation maybe-insert) + :foreign-insert) + (eql o (fm-instance maybe-insert))))) + (prog1 (setf (slot-value dao (slot-definition-name slotd)) + (foreign-slot-delete! + (slot-value dao (slot-definition-name slotd)) + foreign-dao)) + (setf %fm (remove inserted-fm-op %fm))) + (error + "Foreign reference ~A not previously inserted in object ~A (~A)" + foreign-dao dao (slot-value dao (slot-definition-name slotd)))))))) hunk ./src/foreign-relation-slots.lisp 215 + +(defun apply-pending-foreign-operations (object slotd relations) + "Performs any pending foreign operations on SLOTD when reloading a +slot after calling FOREIGN-RELATIONS-MAKUNOUND" + (if-bind pending-operations (reverse + (remove slotd (slot-value object + '%foreign-modifications) + :test-not #'eql + :key #'fm-slotd)) + (progn + (dolist (op pending-operations) + (setf relations + (ecase (fm-operation op) + ((:foreign-insert) (foreign-slot-insert! relations + (fm-instance op))) + ((:foreign-update) (foreign-slot-update! relations + (fm-instance op))) + ((:foreign-delete) (foreign-slot-delete! relations + (fm-instance op)))))) + + relations) + relations)) + +(defmethod find-foreign-relations :around ((class db-access-class) object slotd) + (apply-pending-foreign-operations object slotd (call-next-method))) }