[Foreign relation update/insert/delete support clinton@unknownlamer.org**20100617011546 Ignore-this: 5105008788552ac8bf3e08690aed47b7 * {insert,update,delete,modify}-foreign-object work on :referenced-from slots and allow for them to be modified and then updated when the object is inserted or updated * I'm not the biggest fan of this, but it gets the job done and it seems no other CL ORM even attempts to handle this... ] { hunk ./rofl.asd 38 + (:file "foreign-relation-slots") hunk ./src/db-access-class.lisp 3 - hunk ./src/db-access-object-sql.lisp 83 -(defun foreign-relations-makunbound (object) - (when (persistentp object) - (dolist (s (class-slots (class-of object)) object) - (if (slot-definition-foreign-relation s) - (slot-makunbound-using-class (class-of object) object s))))) hunk ./src/db-access-object-sql.lisp 169 + (update-foreign-objects object) hunk ./src/db-access-object-sql.lisp 194 - + ;; Update related tables *before* updating primary object in case + ;; any CASCADEd columns are changed + (update-foreign-objects object) hunk ./src/db-access-object.lisp 3 +(defstruct %foreign-mods + (insert nil) + (update nil) + (delete nil)) + hunk ./src/db-access-object.lisp 9 - ((%persistent/modifications :transient t)) + ((%persistent/modifications :transient t) + (%foreign-modifications :initform (make-%foreign-mods) + :transient t)) addfile ./src/foreign-relation-slots.lisp hunk ./src/foreign-relation-slots.lisp 1 +(in-package #:rofl) hunk ./src/foreign-relation-slots.lisp 3 +;;; Modification of :referenced-from slots + +;;; Not the best, but the alternatives didn't seem any better at the +;;; time + +;;; TODO +;;; - How should slot-modified-p behave with :referenced-from slots? +;;; - Should modify-foreign-object use the result of MUTATOR, or +;;; instead require everything be done via side effects + +;;; - Would a general stored command list that could be executed +;;; within a single transaction (given the constraints with +;;; continuations when used with ucw) be better than this? + +(defgeneric insert-foreign-object (dao slot foreign-dao)) +(defgeneric update-foreign-object (dao slot foreign-dao)) +(defgeneric delete-foreign-object (dao slot foreign-dao)) + +(defmethod insert-foreign-object (dao (slot-name symbol) foreign-dao) + (if-bind slotd (find slot-name (class-slots (class-of dao)) + :key #'slot-definition-name) + (insert-foreign-object dao slotd foreign-dao) + (error "Invalid slot name ~A for class ~A" slot-name (class-of dao)))) + +(defmethod update-foreign-object (dao (slot-name symbol) foreign-dao) + (if-bind slotd (find slot-name (class-slots (class-of dao)) + :key #'slot-definition-name) + (update-foreign-object dao slotd foreign-dao) + (error "Invalid slot name ~A for class ~A" slot-name (class-of dao)))) + +(defmethod delete-foreign-object (dao (slot-name symbol) foreign-dao) + (if-bind slotd (find slot-name (class-slots (class-of dao)) + :key #'slot-definition-name) + (delete-foreign-object dao slotd foreign-dao) + (error "Invalid slot name ~A for class ~A" slot-name (class-of dao)))) + +(defun table-name-compatible-with-slot (slot dao) + (equal (class-table-name (find-class (slot-definition-foreign-relation slot))) + (class-table-name (class-of dao)))) + +(defun foreign-relations-makunbound (object) + (when (persistentp object) + (dolist (s (class-slots (class-of object)) object) + (if (slot-definition-foreign-relation s) + (slot-makunbound-using-class (class-of object) object s))))) + +(defmethod insert-foreign-object ((dao standard-db-access-object) + (slot db-access-slot-definition) + (foreign-dao standard-db-access-object)) + (assert (and (not (persistentp foreign-dao)) + (table-name-compatible-with-slot slot foreign-dao)) + (dao slot foreign-dao) + "Dragons: ~A ~A ~A" dao slot foreign-dao) + (with-slots ((%fm %foreign-modifications)) + dao + ;; Kind of hackish storing the column name here, but everything + ;; else is a bit hackish too... + (pushnew (cons foreign-dao (slot-definition-foreign-join-spec slot)) + (%foreign-mods-insert %fm) :test #'equal) + (pushnew foreign-dao (slot-value dao (slot-definition-name slot))) + foreign-dao)) + + +(defmethod update-foreign-object ((dao standard-db-access-object) + (slot db-access-slot-definition) + (foreign-dao standard-db-access-object)) + (assert (and (persistentp dao) + (persistentp foreign-dao) + (table-name-compatible-with-slot slot foreign-dao)) + (dao slot foreign-dao) + "Dragons: ~A ~A ~A" dao slot foreign-dao) + ;; fixme: ensure that fkey actually points to dao + (with-slots ((%fm %foreign-modifications)) + dao + (pushnew foreign-dao (%foreign-mods-update %fm)) + (when-bind obsolete-dao (find foreign-dao + (slot-value dao (slot-definition-name slot)) + :test (lambda (e1 e2) (and (db= e1 e2) + (not (eq e1 e2))))) + (setf (slot-value dao (slot-definition-name slot)) + (nsubst foreign-dao obsolete-dao + (slot-value dao (slot-definition-name slot))))) + foreign-dao)) + +(defun modify-foreign-object (dao slot foreign-dao mutator) + "Call UPDATE-FOREIGN-OBJECT with the result of (FUNCALL MUTATOR FOREIGN-DAO)" + (update-foreign-object dao slot (funcall mutator foreign-dao))) + +(defmethod delete-foreign-object ((dao standard-db-access-object) + (slot db-access-slot-definition) + (foreign-dao standard-db-access-object)) + (assert (and (persistentp dao) + (persistentp foreign-dao) + (table-name-compatible-with-slot slot foreign-dao)) + (dao slot foreign-dao) + "Dragons: ~A ~A ~A" dao slot foreign-dao) + ;; fixme: ensure that fkey actually points to do + (with-slots ((%fm %foreign-modifications)) + dao + (pushnew foreign-dao (%foreign-mods-delete %fm)) + (setf (slot-value dao (slot-definition-name slot)) + (delete foreign-dao (slot-value dao (slot-definition-name slot)) + :test #'db=)))) + +(defun update-foreign-objects (dao) + (with-slots ((%fm %foreign-modifications)) + dao + (mapc (lambda (insert-spec) + (destructuring-bind (o . col) + insert-spec + (setf (slot-value o (or col (class-id-column-name (class-of dao)))) + (object-id dao)) + (insert-object o))) + (delete-duplicates (%foreign-mods-insert %fm) + :test #'eql + :key #'car)) + (mapc #'update-object + (delete-duplicates (%foreign-mods-update %fm) + :test #'db=)) + (mapc #'delete-object + (delete-duplicates (%foreign-mods-delete %fm) + :test #'db=)) + ;; Clear foreign modifications + (setf (slot-value dao '%foreign-modifications) (make-%foreign-mods)) + (foreign-relations-makunbound dao))) hunk ./src/packages.lisp 28 + #:insert-foreign-object + #:update-foreign-object + #:delete-foreign-object + #:modify-foreign-object }