root/trunk/bknr/datastore/src/data/object.lisp

;;; MOP based object subsystem for the BKNR datastore

;; Internal slots should have a different slot descriptor class, (setf
;; slot-value-using-class) should only be defined for
;; application-defined slots, not internal slots (like ID, maybe
;; others).

;; get-internal-real-time, get-internal-run-time, get-universal-time
;; need to be shadowed and disallowed.

(in-package :bknr.datastore)

(define-condition inconsistent-slot-persistence-definition (store-error)
  ((class :initarg :class)
   (slot-name :initarg :slot-name))
  (:report (lambda (e stream)
             (with-slots (slot-name class) e
               (format stream "Slot ~A in class ~A declared as both transient and persistent"
                       slot-name class)))))

(define-condition object-subsystem-not-found-in-store (store-error)
  ((store :initarg :store))
  (:report (lambda (e stream)
             (with-slots (store) e
               (format stream "Could not find a store-object-subsystem in the current store ~A" store)))))

(define-condition persistent-slot-modified-outside-of-transaction (store-error)
  ((slot-name :initarg :slot-name)
   (object :initarg :object))
  (:report (lambda (e stream)
             (with-slots (slot-name object) e
               (format stream "Attempt to modify persistent slot ~A of ~A outside of a transaction"
                       slot-name object)))))

(defclass store-object-subsystem ()
  ((next-object-id :initform 0
                   :accessor next-object-id
                   :documentation "Next object ID to assign to a new object")))

(defun store-object-subsystem ()
  (let ((subsystem (find-if (alexandria:rcurry #'typep 'store-object-subsystem)
                            (store-subsystems *store*))))
    (unless subsystem
      (error 'object-subsystem-not-found-in-store :store *store*))
    subsystem))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (finalize-inheritance
   (defclass persistent-class (indexed-class)
     ())))

(defmethod validate-superclass ((sub persistent-class) (super indexed-class))
  t)

(defvar *suppress-schema-warnings* nil)

(deftransaction update-instances-for-changed-class (class)
  (let ((instance-count (length (class-instances class))))
    (when (plusp instance-count)
      (unless *suppress-schema-warnings*
        (report-progress "~&; updating ~A instances of ~A for class changes~%"
                         instance-count class))
      (mapc #'reinitialize-instance (class-instances class)))))

(defmethod reinitialize-instance :after ((class persistent-class) &key)
  (when (and (boundp '*store*) *store*)
    (update-instances-for-changed-class (class-name class))
    (unless *suppress-schema-warnings*
      (report-progress "~&; class ~A has been changed. To ensure correct schema ~
                              evolution, please snapshot your datastore.~%"
                       (class-name class)))))

(defclass persistent-direct-slot-definition (index-direct-slot-definition)
  ((relaxed-object-reference :initarg :relaxed-object-reference
                             :initform nil)
   (transient :initarg :transient
              :initform nil)))

(defclass persistent-effective-slot-definition (index-effective-slot-definition)
  ((relaxed-object-reference :initarg :relaxed-object-reference
                             :initform nil)
   (transient :initarg :transient
              :initform nil)))


(defgeneric transient-slot-p (slotd)
  (:method ((slotd t))
    t)
  (:method ((slotd persistent-direct-slot-definition))
    (slot-value slotd 'transient))
  (:method ((slotd persistent-effective-slot-definition))
    (slot-value slotd 'transient)))

(defgeneric relaxed-object-reference-slot-p (slotd)
  (:method ((slotd t))
    nil)
  (:method ((slotd persistent-effective-slot-definition))
    (slot-value slotd 'relaxed-object-reference))
  (:documentation "Return whether the given slot definition specifies
that the slot is relaxed.  If a relaxed slot holds a pointer to
another persistent object and the pointed-to object is deleted, slot
reads will return nil."))

(defun undo-set-slot (object slot-name value)
  (if (eq value 'unbound)
      (slot-makunbound object slot-name)
      (setf (slot-value object slot-name) value)))

(defmethod (setf slot-value-using-class) :before ((newval t)
                                                  (class persistent-class)
                                                  object
                                                  (slotd persistent-effective-slot-definition))
  (unless (transient-slot-p slotd)
    (let ((slot-name (slot-definition-name slotd)))
      (unless (or (in-transaction-p)
                  (member slot-name '(last-change id)))
        (error 'persistent-slot-modified-outside-of-transaction :slot-name slot-name :object object))
      (when (in-anonymous-transaction-p)
        (push (list #'undo-set-slot
                    object
                    (slot-definition-name slotd)
                    (if (slot-boundp object (slot-definition-name slotd))
                        (slot-value object (slot-definition-name slotd))
                        'unbound))
              (anonymous-transaction-undo-log *current-transaction*)))
      (when (and (not (eq :restore (store-state *store*)))
                 (not (member slot-name '(last-change id))))
        (setf (slot-value object 'last-change) (current-transaction-timestamp))))))

(defmethod (setf slot-value-using-class) :after (newval
                                                 (class persistent-class)
                                                 object
                                                 (slotd persistent-effective-slot-definition))
  (when (and (not (transient-slot-p slotd))
             (in-anonymous-transaction-p)
             (not (member (slot-definition-name slotd) '(last-change id))))
    (encode (make-instance 'transaction
                           :timestamp (transaction-timestamp *current-transaction*)
                           :function-symbol 'tx-change-slot-values
                           :args (list object (slot-definition-name slotd) newval))
            (anonymous-transaction-log-buffer *current-transaction*))))

(define-condition transient-slot-cannot-have-initarg (store-error)
  ((class :initarg :class)
   (slot-name :initarg :slot-name))
  (:documentation "A transient slot may not have an :initarg
  specified, as initialize-instance is only used for persistent
  initialization.")
  (:report (lambda (e stream)
             (with-slots (class slot-name) e
               (format stream "The transient slot ~A in class ~A was defined as having an initarg, which is not supported"
                       slot-name (class-name class))))))

(defmethod direct-slot-definition-class ((class persistent-class) &key initargs transient name)
  ;; It might be better to do the error checking in an
  ;; initialize-instance method of persistent-direct-slot-definition
  (when (and initargs transient)
    (error 'transient-slot-cannot-have-initarg :class class :slot-name name))
  'persistent-direct-slot-definition)

(defmethod effective-slot-definition-class ((class persistent-class) &key)
  'persistent-effective-slot-definition)

(defmethod compute-effective-slot-definition :around ((class persistent-class) name direct-slots)
  (unless (or (every #'transient-slot-p direct-slots)
              (notany #'transient-slot-p direct-slots))
    (error 'inconsistent-slot-persistence-definition :class class :slot-name name))
  (let ((effective-slot-definition (call-next-method)))
    (when (typep effective-slot-definition 'persistent-effective-slot-definition)
      (with-slots (relaxed-object-reference transient) effective-slot-definition
        (setf relaxed-object-reference (some #'relaxed-object-reference-slot-p direct-slots)
              transient (slot-value (first direct-slots) 'transient))))
    effective-slot-definition))

(defmethod class-persistent-slots ((class standard-class))
  (remove-if #'transient-slot-p (class-slots class)))

(defclass store-object ()
  ((id :initarg :id
       :reader store-object-id
       :type integer
       :index-type unique-index
       :index-initargs (:test #'eql)
       :index-reader store-object-with-id :index-values all-store-objects
       :index-mapvalues map-store-objects)
   (last-change :initform (get-universal-time)
                :initarg :last-change))
  (:metaclass persistent-class)
  (:class-indices (all-class :index-type class-skip-index
                             :index-subclasses t
                             :index-initargs (:index-superclasses t)
                             :index-keys all-store-classes
                             :index-reader store-objects-with-class
                             :slots (id))))

(defun class-instances (class)
  (find-class class)                 ; make sure that the class exists
  (store-objects-with-class class))

(deftransaction store-object-touch (object)
  "Update the LAST-CHANGE slot to reflect the current transaction timestamp."
  (setf (slot-value object 'last-change) (current-transaction-timestamp)))

(defgeneric store-object-last-change (object depth)
  (:documentation "Return the last change time of the OBJECT.  DEPTH
  determines how deep the object graph will be traversed.")

  (:method ((object t) (depth integer))
    0)

  (:method ((object store-object) (depth (eql 0)))
    (slot-value object 'last-change))

  (:method ((object store-object) depth)
    (let ((last-change (slot-value object 'last-change)))
      (dolist (slotd (class-slots (class-of object)))
        (let* ((slot-name (slot-definition-name slotd))
               (child (and (slot-boundp object slot-name)
                           (slot-value object slot-name))))
          (setf last-change
                (cond
                  ((null child)
                   last-change)
                  ((typep child 'store-object)
                   (max last-change (store-object-last-change child (1- depth))))
                  ((listp child)
                   (reduce #'max child
                           :key (alexandria:rcurry 'store-object-last-change (1- depth))
                           :initial-value last-change))
                  (t
                   last-change)))))
      last-change)))

#+allegro
(aclmop::finalize-inheritance (find-class 'store-object))

(defmethod initialize-instance :around ((object store-object) &rest initargs &key)
  (setf (slot-value object 'id) (allocate-next-object-id))
  (cond
    ((not (in-transaction-p))
     (with-store-guard ()
       (let ((transaction (make-instance 'transaction
                                         :function-symbol 'make-instance
                                         :timestamp (get-universal-time)
                                         :args (cons (class-name (class-of object))
                                                     (append (list :id (slot-value object 'id))
                                                             initargs)))))
         (with-statistics-log (*transaction-statistics* (transaction-function-symbol transaction))
           (with-transaction-log (transaction)
             (call-next-method))))))
    ((in-anonymous-transaction-p)
     (encode (make-instance 'transaction
                            :function-symbol 'make-instance
                            :timestamp (transaction-timestamp *current-transaction*)
                            :args (cons (class-name (class-of object)) initargs))
             (anonymous-transaction-log-buffer *current-transaction*))
     (call-next-method))
    (t
     (call-next-method))))

(defvar *allocate-object-id-lock* (bt:make-lock "Persistent Object ID Creation"))

(defun allocate-next-object-id ()
  (mp-with-lock-held (*allocate-object-id-lock*)
    (let ((id (next-object-id (store-object-subsystem))))
      (incf (next-object-id (store-object-subsystem)))
      id)))
    
(defun initialize-transient-slots (object)
  (dolist (slotd (class-slots (class-of object)))
    (when (and (typep slotd 'persistent-effective-slot-definition)
               (transient-slot-p slotd)
               (slot-definition-initfunction slotd))
      (setf (slot-value object (slot-definition-name slotd))
            (funcall (slot-definition-initfunction slotd))))))
 
(defmethod initialize-instance :after ((object store-object) &key)
  ;; This is called only when initially creating the (persistent)
  ;; instance, not during restore.  During restore, the
  ;; INITIALIZE-TRANSIENT-INSTANCE function is called for all
  ;; persistent objects after the snapshot has been read, but before
  ;; running the transaction log.
  (initialize-transient-instance object))

(defmacro print-store-object ((object stream &key type) &body body)
  ;; variable capture accepted here.
  `(print-unreadable-object (,object ,stream :type ,type)
     (format stream "ID: ~D " (store-object-id ,object))
     ,@body))

(defmethod print-object ((object store-object) stream)
  (print-unreadable-object (object stream :type t)
    (format stream "ID: ~D" (store-object-id object))))

(defmethod print-object :around ((object store-object) stream)
  (if (object-destroyed-p object)
      (print-unreadable-object (object stream :type t)
        (princ "DESTROYED" stream))
      (call-next-method)))

(defmethod change-class :before ((object store-object) class &rest args)
  (declare (ignore class args))
  (when (not (in-transaction-p))
    (error "Can't change class of persistent object ~A using change-class ~
            outside of transaction, please use PERSISTENT-CHANGE-CLASS instead" object)))

(defun tx-persistent-change-class (object class-name &rest args)
  (warn "TX-PERSISTENT-CHANGE-CLASS does not maintain class indices, ~
         please snapshot and restore to recover indices")
  (apply #'change-class object (find-class class-name) args))

(defun persistent-change-class (object class &rest args)
  (execute (make-instance 'transaction :function-symbol 'tx-persistent-change-class
                          :timestamp (get-universal-time)
                          :args (append (list object (if (symbolp class) class (class-name class))) args))))

(defgeneric initialize-transient-instance (store-object)
  (:documentation
   "Initializes the transient aspects of a persistent object. This
method is called after a persistent object has been initialized, also
when the object is loaded from a snapshot, but before reading the
transaction log."))

(defmethod initialize-transient-instance ((object store-object)))

(defmethod store-object-persistent-slots ((object store-object))
  (mapcar #'slot-definition-name (class-persistent-slots (class-of object))))

(defmethod store-object-relaxed-object-reference-p ((object store-object) slot-name)
  (let ((slot (find slot-name (class-slots (class-of object)) :key #'slot-definition-name)))
    (when slot
      (relaxed-object-reference-slot-p slot))))

(defmacro define-persistent-class (class (&rest superclasses) slots &rest class-options)
  (let ((superclasses (or superclasses '(store-object)))
        (metaclass (cadr (assoc :metaclass class-options))))
    (when (and metaclass
               (not (validate-superclass (find-class metaclass)
                                         (find-class 'persistent-class))))
      (error "Can not define a persistent class with metaclass ~A." metaclass))
    `(define-bknr-class ,class ,superclasses ,slots
                        ,@(unless metaclass '((:metaclass persistent-class)))
                        ,@class-options)))

(defmacro defpersistent-class (class (&rest superclasses) slots &rest class-options)
  (let ((superclasses (or superclasses '(store-object)))
        (metaclass (cadr (assoc :metaclass class-options))))
    (when (and metaclass
               (not (validate-superclass (find-class metaclass)
                                         (find-class 'persistent-class))))
      (error "Can not define a persistent class with metaclass ~A." metaclass))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defclass ,class ,superclasses ,slots
         ,@(unless metaclass '((:metaclass persistent-class)))
         ,@class-options))))

;;; binary snapshot

(defvar *current-object-slot* nil)
(defvar *current-slot-relaxed-p* nil)

(defun encode-layout (id class slots stream)
  (%write-tag #\L stream)
  (%encode-integer id stream)
  (%encode-symbol (class-name class) stream)
  (%encode-integer (length slots) stream)
  (dolist (slot slots)
    (%encode-symbol slot stream)))

(defun %encode-set-slots (slots object stream)
  (dolist (slot slots)
    (let ((*current-object-slot* (list object slot))
          (*current-slot-relaxed-p* (store-object-relaxed-object-reference-p object slot)))
      (encode (if (slot-boundp object slot)
                  (slot-value object slot)
                  'unbound)
              stream))))

(defun encode-create-object (class-layouts object stream)
  (let* ((class (class-of object))
         (layout (gethash class class-layouts)))
    (unless layout
      (setf layout
            (cons (hash-table-count class-layouts)
                  ;; XXX layout muss konstant sein
                  (sort (remove 'id (store-object-persistent-slots object))
                        #'string< :key #'symbol-name)))
      (encode-layout (car layout) class (cdr layout) stream)
      (setf (gethash class class-layouts) layout))
    (destructuring-bind (layout-id &rest slots) layout
      (declare (ignore slots))
      (%write-tag #\O stream)
      (%encode-integer layout-id stream)
      (%encode-integer (store-object-id object) stream))))

(defun encode-set-slots (class-layouts object stream)
  (destructuring-bind (layout-id &rest slots)
      (gethash (class-of object) class-layouts)
    (%write-tag #\S stream)
    (%encode-integer layout-id stream)
    (%encode-integer (store-object-id object) stream)
    (%encode-set-slots slots object stream)))

(defun find-class-with-interactive-renaming (class-name)
  (loop until (or (null class-name)
                  (find-class class-name nil))
     do (progn
          (format *query-io* "Class ~A not found, enter new class or enter ~
                              NIL to ignore objects of this class: "
                  class-name)
          (finish-output *query-io*)
          (setq class-name (read *query-io*))))
  (and class-name
       (find-class class-name)))

(defun find-slot-name-with-interactive-rename (class slot-name)
  (loop until (find slot-name (class-slots class) :key #'slot-definition-name)
     do (format *query-io* "Slot ~S not found in class ~S, enter new slot name: "
                slot-name (class-name class))
     do (setq slot-name (read *query-io*))
     finally (return slot-name)))

(defvar *slot-name-map*)

(defun rename-slot (class slot-name)
  (or (caddr (find (list (class-name class) slot-name) *slot-name-map*
                   :key #'(lambda (entry) (subseq entry 0 2)) :test #'equal))
      (find (symbol-name slot-name)
            (mapcar #'slot-definition-name (class-slots class)) :key #'symbol-name :test #'equal)))

(defgeneric convert-slot-value-while-restoring (object slot-name value)
  (:documentation "Generic function to be called to convert a slot's
  value from a previous snapshot layout.  OBJECT is the object that is
  being restored, SLOT-NAME is the name of the slot in the old schema,
  VALUE is the value of the slot in the old schema.")
  (:method (object slot-name value)
    (setf (slot-value object slot-name) value)))

(defun find-slot-name-with-automatic-rename (class slot-name)
  (if (find slot-name (class-slots class) :key #'slot-definition-name)
      slot-name
      (restart-case
          (let ((new-slot-name (rename-slot class slot-name)))
            (cond
              (new-slot-name
               (warn "slot ~S not found in class ~S, automatically renamed to ~S"
                     slot-name (class-name class) new-slot-name)
               new-slot-name)
              (t
               (error "can't find a slot in class ~A which matches the name ~A used in the store snapshot"
                      (class-name class) slot-name))))
        (convert-values ()
          :report "Convert slot values using CONVERT-SLOT-VALUE-WHILE-RESTORING"
          (cons 'convert-slot-values slot-name))
        (ignore-slot ()
          :report "Ignore slot, discarding values found in the snapshot file"
          nil))))

(defun find-class-slots-with-interactive-renaming (class slot-names)
  #+(or)
  (format t "; verifying class layout for class ~A~%; slots:~{ ~S~}~%" (class-name class)
          (mapcar #'slot-definition-name (class-slots class)))
  (loop for slot-name in slot-names
     collect (find-slot-name-with-automatic-rename class slot-name)))

(defun snapshot-read-layout (stream layouts)
  (let* ((id (%decode-integer stream))
         (class-name (%decode-symbol stream :usage "class"))
         (nslots (%decode-integer stream))
         (class (find-class-with-interactive-renaming class-name))
         (slot-names (loop repeat nslots collect (%decode-symbol stream
                                                                 :intern (not (null class))
                                                                 :usage "slot")))
         (slots (if class
                    (find-class-slots-with-interactive-renaming class slot-names)
                    slot-names)))
    (setf (gethash id layouts)
          (cons class slots))))

(defun %read-slots (stream object slots)
  "Read the OBJECT from STREAM.  The individual slots of the object
are expected in the order of the list SLOTS.  If the OBJECT is NIL,
the slots are read from the snapshot and ignored."
  (declare (optimize (speed 3)))
  (dolist (slot-name slots)
    (let ((value (decode stream)))
      (cond
        ((consp slot-name)
         (assert (eq 'convert-slot-values (car slot-name)))
         (convert-slot-value-while-restoring object (cdr slot-name) value))
        ((null slot-name)
         ;; ignore value
         )
        (t
         (restart-case
             (let ((*current-object-slot* (list object slot-name))
                   (*current-slot-relaxed-p* (or (null object)
                                                 (store-object-relaxed-object-reference-p object slot-name))))
               (when object
                 (let ((bknr.indices::*indices-remove-p* nil))
                   (if (eq value 'unbound)
                       (slot-makunbound object slot-name)
                       (convert-slot-value-while-restoring object slot-name value)))))
           (set-slot-nil ()
             :report "Set slot to NIL."
             (setf (slot-value object slot-name) nil))
           (make-slot-unbound ()
             :report "Make slot unbound."
             (slot-makunbound object slot-name))))))))

(defun snapshot-read-object (stream layouts)
  (declare (optimize (speed 3)))
  (with-simple-restart (skip-object "Skip the object.")
    (let* ((layout-id (%decode-integer stream))
           (object-id (%decode-integer stream))
           (class (first (gethash layout-id layouts))))
      ;; If the class is NIL, it was not found in the currently
      ;; running Lisp image and objects of this class will be ignored.
      (when class
        (let ((object (allocate-instance class)))
          (setf (slot-value object 'id) object-id
                (next-object-id (store-object-subsystem)) (max (1+ object-id)
                                                               (next-object-id (store-object-subsystem))))
          (dolist (index (class-slot-indices class 'id))
            (index-add index object)))))))

(defun snapshot-read-slots (stream layouts)
  (let* ((layout-id (%decode-integer stream))
         (object-id (%decode-integer stream))
         (object (store-object-with-id object-id)))
    (restart-case
        (%read-slots stream object (cdr (gethash layout-id layouts)))
      (skip-object-initialization ()
        :report "Skip object initialization.")
      (delete-object ()
        :report "Delete the object."
        (delete-object object)))))

(defmethod encode-object ((object store-object) stream)
  (if (object-destroyed-p object)
      (let* ((*indexed-class-override* t)
             (id (store-object-id object))
             (container (first *current-object-slot*))
             (slot (second *current-object-slot*)))

        ;; if we are not encoding slot values, something has gone
        ;; wrong with the indices
        (unless (and container slot)
          (warn "Encoding destroyed object with ID ~A." id)
          (%write-tag #\o stream)
          (%encode-integer id stream)
          (return-from encode-object))

        (if *current-slot-relaxed-p*
            ;; the slot can contain references to deleted objects, just warn
            (progn
              (warn "Encoding reference to destroyed object with ID ~A from slot ~A of object ~A with ID ~A."
                    id slot (type-of container) (store-object-id container))
              (%write-tag #\o stream)
              (%encode-integer id stream))
            ;; the slot can't contain references to deleted objects, throw an error
            (error "Encoding reference to destroyed object with ID ~A from slot ~A of object ~A with ID ~A."
                   id slot (type-of container) (store-object-id container))))

      ;; Go ahead and serialize the object reference
      (progn (%write-tag #\o stream)
             (%encode-integer (store-object-id object) stream))))

(defmethod decode-object ((tag (eql #\o)) stream)
  (let ((*current-object-slot* nil))
    (%decode-store-object stream)))

(define-condition invalid-reference (warning)
  ((id :initarg :id))
  (:report (lambda (e stream)
             (format stream "internal inconsistency during restore - store object with ID ~A could not be found"
                     (slot-value e 'id)))))

(defun %decode-store-object (stream)
  ;; This is actually called in two contexts, when a slot-value is to
  ;; be filled with a reference to a store object and when a list of
  ;; store objects is read from the transaction log (%decode-list).
  ;; In the former case, references two deleted objects are accepted
  ;; when the slot pointing to the object is marked as being a
  ;; "relaxed-object-reference", in the latter case, no such
  ;; information is available.  To ensure maximum restorability of
  ;; transaction logs, object references stored in lists are always
  ;; considered to be relaxed references, which means that references
  ;; to deleted objects are restored as NIL.  Applications must be
  ;; prepared to cope with NIL entries in such object lists (usually
  ;; lists in slots).
  (let* ((id (%decode-integer stream))
         (object (or (store-object-with-id id)
                     (warn 'invalid-reference :id id)))
         (container (first *current-object-slot*))
         (slot-name (second *current-object-slot*)))
    (cond (object object)

          ((or *current-slot-relaxed-p* (not container))
           (if container
               (warn "Reference to inexistent object with id ~A in relaxed slot ~A of object ~
                      with class ~A with ID ~A."
                     id slot-name (type-of container) (store-object-id container))
               (warn "Reference to inexistent object with id ~A from unnamed container, returning NIL." id))

           ;; Possibly determine new "current object id"
           (when (>= id (next-object-id (store-object-subsystem)))
             (setf (next-object-id (store-object-subsystem)) (1+ id)))
           nil)

          (t (error "Reference to inexistent object with id ~A from slot ~A of object ~A with ID ~A."
                    id slot-name (type-of container)
                    (if container (store-object-id container) "unknown object"))))))

(defun encode-current-object-id (stream)
  (%write-tag #\I stream)
  (%encode-integer (next-object-id (store-object-subsystem)) stream))

(defmethod snapshot-subsystem ((store store) (subsystem store-object-subsystem))
  (let ((snapshot (store-subsystem-snapshot-pathname store subsystem)))
    (with-open-file (s snapshot
                       :direction :output
                       :element-type '(unsigned-byte 8)
                       :if-does-not-exist :create
                       :if-exists :supersede)
      (let ((class-layouts (make-hash-table)))
        (with-transaction (:prepare-for-snapshot)
          (map-store-objects #'prepare-for-snapshot))
        (encode-current-object-id s)
        (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object)
                                              (encode-create-object class-layouts object s))))
        (map-store-objects (lambda (object) (when (subtypep (type-of object) 'store-object)
                                              (encode-set-slots class-layouts object s))))
        t))))

(defmethod close-subsystem ((store store) (subsystem store-object-subsystem))
  (dolist (class-name (all-store-classes))
    (clear-class-indices (find-class class-name))))

(defmethod restore-subsystem ((store store) (subsystem store-object-subsystem) &key until)
  ;; XXX check that until > snapshot time
  (declare (ignore until))
  (let ((snapshot (store-subsystem-snapshot-pathname store subsystem)))
    ;; not all indices that should be cleared are cleared. maybe
    ;; check on first instatiation of a class?
    (dolist (class-name (cons 'store-object (all-store-classes)))
      (clear-class-indices (find-class class-name)))
    (setf (next-object-id subsystem) 0)
    (when (probe-file snapshot)
      (report-progress "~&; loading snapshot file ~A~%" snapshot)
      (with-open-file (s snapshot
                         :element-type '(unsigned-byte 8)
                         :direction :input)
        (let ((class-layouts (make-hash-table))
              (created-objects 0)
              (read-slots 0)
              (error t)
              (*slot-name-map* nil))
          (unwind-protect
               (progn
                 (with-simple-restart
                     (finalize-object-subsystem "Finalize the object subsystem.")
                   (loop
                      (when (and (plusp created-objects)
                                 (zerop (mod created-objects 10000)))
                        #+nil (format t "Snapshot position ~A~%" (file-position s))
                        (report-progress "~A objects created.~%" created-objects)
                        (force-output))
                      (when (and (plusp read-slots)
                                 (zerop (mod read-slots 10000)))
                        (report-progress "~A of ~A objects initialized.~%" read-slots created-objects)
                        (force-output))
                      (let ((char (%read-tag s nil nil)))
                        (unless (member char '(#\I #\L #\O #\S nil))
                          (error "unknown char ~A at offset ~A~%" char (file-position s)))
                        (ecase char
                          ((nil) (return))
                          (#\I (setf (next-object-id (store-object-subsystem)) (%decode-integer s)))
                          (#\L (snapshot-read-layout s class-layouts))
                          (#\O (snapshot-read-object s class-layouts) (incf created-objects))
                          (#\S (snapshot-read-slots s class-layouts) (incf read-slots))))))
                 (map-store-objects #'initialize-transient-slots)
                 (map-store-objects #'initialize-transient-instance)
                 (setf error nil))
            (when error
              (maphash #'(lambda (key val)
                           (declare (ignore key))
                           (let ((class-name (car val)))
                             (report-progress "clearing indices for class ~A~%" (class-name class-name))
                             (clear-class-indices class-name)))
                       class-layouts))))))))

(defun tx-delete-object (id)
  (destroy-object (store-object-with-id id)))

(defun delete-object (object)
  (if (and (in-transaction-p)
           (not (in-anonymous-transaction-p)))
      (destroy-object object)
      (execute (make-instance 'transaction :function-symbol 'tx-delete-object
                              :timestamp (get-universal-time)
                              :args (list (store-object-id object))))))

(defun tx-delete-objects (&rest object-ids)
  (mapc #'(lambda (id) (destroy-object (store-object-with-id id))) object-ids))

(defun delete-objects (&rest objects)
  (if (in-transaction-p)
      (mapc #'destroy-object objects)
      (execute (make-instance 'transaction :function-symbol 'tx-delete-objects
                              :timestamp (get-universal-time)
                              :args (mapcar #'store-object-id objects)))))

(defgeneric cascade-delete-p (object referencing-object)
  (:method (object referencing-object)
    (declare (ignore object referencing-object))
    nil)
  (:documentation "return non-nil if the REFERENCING-OBJECT should be deleted when the OBJECT is deleted"))

(defun partition-list (list predicate)
  "Return two list values, the first containing all elements from LIST
that satisfy PREDICATE, the second those that don't"
  (let (do dont)
    (dolist (element list)
      (if (funcall predicate element)
          (push element do)
          (push element dont)))
    (values do dont)))

(defun cascading-delete-object (object)
  "Delete the OBJECT and all objects that reference it and that are eligible to cascading deletes, as indicated by
the result of calling CASCADE-DELETE-P.  Generate error if there are references to the objects that are not eligible
to cascading deletes."
  (multiple-value-bind (cascading-delete-refs
                        remaining-refs)
      (partition-list (find-refs object) (alexandria:curry #'cascade-delete-p object))
    (when remaining-refs
      (error "Cannot delete object ~A because there are references ~
              to this object in the system, please consult a system administrator!"
             object))
    (apply #'delete-objects object cascading-delete-refs)))

(defun tx-change-slot-values (object &rest slots-and-values)
  "Called by the MOP to change a persistent slot's value."
  (unless (in-transaction-p)
    (error 'not-in-transaction))
  (when object
    (loop for (slot value) on slots-and-values by #'cddr
       do (setf (slot-value object slot) value))))

(defun change-slot-values (object &rest slots-and-values)
  "This function is the deprecated way to set slots of persistent
   objects."
  (warn "CHANGE-SLOT-VALUES is deprecated - use WITH-TRANSACTION and standard accessors!")
  (execute (make-instance 'transaction
                          :function-symbol 'tx-change-slot-values
                          :timestamp (get-universal-time)
                          :args (list* object slots-and-values))))

(defgeneric prepare-for-snapshot (object)
  (:method ((object store-object))
    nil)
  (:documentation "Called for every store object before a snapshot is
  written."))

(defun find-store-object (id-or-name &key (class 'store-object) query-function key-slot-name)
  "Mock up implementation of find-store-object API as in the old datastore.
Note: QUERY-FUNCTION will only be used if ID-OR-NAME is neither an integer nor a
string designating an integer."
  (unless id-or-name
    (error "can't search a store object with null key"))
  (when (stringp id-or-name)
    (multiple-value-bind (value end) (parse-integer id-or-name :junk-allowed t)
      (when (and value
                 (eql end (length id-or-name)))
        (setq id-or-name value))))
  (let ((result (cond
                  ((numberp id-or-name)
                   (store-object-with-id id-or-name))
                  (t
                   (cond
                     (query-function
                      (funcall query-function id-or-name))
                     ((eq class 't)
                      (error "can't search for store object by name without class specified"))
                     (t
                      (let ((index (bknr.indices::class-slot-index (find-class class) key-slot-name)))
                        (when index
                          (index-get index id-or-name)))))))))
    (unless (or (null result)
                (typep result class))
      (error "Object ~A is not of wanted type ~A." result class))
    result))

(deftransaction store-object-add-keywords (object slot keywords)
  (setf (slot-value object slot)
        (union (slot-value object slot)
               keywords)))

(deftransaction store-object-remove-keywords (object slot keywords)
  (setf (slot-value object slot)
        (set-difference (slot-value object slot) keywords)))

(deftransaction store-object-set-keywords (object slot keywords)
  (setf (slot-value object slot) keywords))

(defmethod find-refs ((object store-object))
  "Find references to the given OBJECT in all store-objects, traversing both single valued and list valued slots."
  (remove-if-not
   (lambda (candidate)
     (find-if (lambda (slotd)
                (and (slot-boundp candidate (slot-definition-name slotd))
                     (let ((slot-value (slot-value candidate (slot-definition-name slotd))))
                       (or (eq object slot-value)
                           (and (alexandria:proper-list-p slot-value)
                                (find object slot-value))))))
              (class-slots (class-of candidate))))
   (class-instances 'store-object)))

(pushnew :mop-store cl:*features*)