|
|
|
|
|
(in-package mito-transactions.dev)
|
|
|
|
|
|
;;;; Cache for `mito` objects with the main purpose of avoiding
|
|
|
;;;; several instances of the same dao which are not `eq` to each
|
|
|
;;;; other. Cached objects are only removed when they are GC'ed so
|
|
|
;;;; next time they will have other identity but it's not a problem
|
|
|
;;;; beause there would be no previous objects to EQ against.
|
|
|
|
|
|
(defmethod mito.dao.mixin:make-dao-instance ((obj cached-dao-class) &key &allow-other-keys)
|
|
|
"This method is called on creation of dao instances loaded from the DB. "
|
|
|
(declare (ignore obj))
|
|
|
(maybe-lock
|
|
|
(let ((*ignore-transaction* t))
|
|
|
(do-cache (call-next-method)))))
|
|
|
|
|
|
(defmethod mito:insert-dao ((obj cached-dao))
|
|
|
(maybe-lock
|
|
|
(call-next-method)
|
|
|
(setf (gethash (mito:object-id obj) (class-cache obj)) obj)
|
|
|
obj))
|
|
|
|
|
|
(defmethod mito:delete-dao ((obj cached-dao))
|
|
|
(maybe-lock
|
|
|
(remhash (mito:object-id obj) (class-cache (class-of obj)))
|
|
|
(call-next-method)))
|
|
|
|
|
|
(defmethod mito:delete-by-values ((class cached-dao-class) &rest fields-and-values)
|
|
|
(maybe-lock
|
|
|
;; We need their IDs to remove from the cache
|
|
|
(let ((objs (apply #'mito:retrieve-dao class fields-and-values)))
|
|
|
(call-next-method)
|
|
|
(dolist (obj objs)
|
|
|
(remhash (mito:object-id obj) (class-cache (class-of obj))))
|
|
|
(values))))
|
|
|
|
|
|
(defgeneric class-cache (class)
|
|
|
(:method ((class cached-dao-class))
|
|
|
(slot-value class 'cache))
|
|
|
(:method ((obj cached-dao))
|
|
|
(class-cache (class-of obj)))
|
|
|
(:method ((classname symbol))
|
|
|
(class-cache (find-class classname))))
|
|
|
|
|
|
(defun get-dao (class id)
|
|
|
"Fetch an object directly from the cache, only check the db if it's not cached."
|
|
|
(maybe-lock
|
|
|
(or (gethash id (class-cache class))
|
|
|
(do-cache (first (mito:select-dao class (sxql:where (:= :id id))))))))
|
|
|
|
|
|
(defun get-dao-from-cache-only (class id)
|
|
|
"Fetch an object directly from the cache, return NIL if it's not cached."
|
|
|
(maybe-lock
|
|
|
(gethash id (class-cache class))))
|
|
|
|
|
|
(defun do-cache (obj)
|
|
|
(when obj
|
|
|
(let ((cache (class-cache obj)))
|
|
|
(sif (gethash (mito:object-id obj) cache)
|
|
|
(copy-fields it obj)
|
|
|
(setf it obj)))))
|
|
|
|
|
|
(defun copy-fields (to from)
|
|
|
(when (local-time:timestamp> (mito:object-updated-at from)
|
|
|
(mito:object-updated-at to))
|
|
|
(let ((*ignore-transaction* t)
|
|
|
(slot-names (mapcar #'c2mop:slot-definition-name
|
|
|
(mito.class.table:table-column-slots (class-of from)))))
|
|
|
(dolist (slot-name slot-names)
|
|
|
(setf (slot-value to slot-name) (slot-value from slot-name)))))
|
|
|
to)
|
|
|
|
