clsql-helper/dirty.lisp at master · AccelerationNet/clsql-helper · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
(in-package :clsql-helper)
(cl-interpol:enable-interpol-syntax)
(clsql:file-enable-sql-reader-syntax)

(defclass dirty-slot ()
  ((slot-name :accessor slot-name :initarg :slot-name :initform nil)
   (old-value :accessor old-value :initarg :old-value :initform nil)
   (new-value :accessor new-value :initarg :new-value :initform nil)))

(defmethod print-object ((o dirty-slot) s)
  "Print the auto-print-items for this instance."
  (print-unreadable-object (o s :type t :identity t)
    (ignore-errors (format s "~A" (slot-name o)))))

(defun make-dirty-slot (name old new)
  (make-instance 'dirty-slot :slot-name name :old-value old :new-value new))

(defclass dirty-db-slots-mixin ()
  ((dirty-slots :accessor dirty-slots :initarg :dirty-slots :initform nil
                :db-kind :virtual)
   (dirty-test :accessor dirty-test :initarg :dirty-test :initform `((T . ,#'equalp))
               :db-kind :virtual))
  (:metaclass clsql-sys::standard-db-class))

(defmethod initialize-instance :after ((o dirty-db-slots-mixin)
                                       &key &allow-other-keys
                                       &aux (class (class-of o)))
  ;; initialize our dirtyness caused by initialization
  ;; during initialization, our dirty slots might not be initialized
  ;; till after the rest of initialization
  (iter (for slot in (clsql::stored-slotdefs o))
    (for sn = (closer-mop:slot-definition-name slot))
    (when (slot-boundp o sn)
      (%dirty-before (slot-value o sn ) class o slot :old-value nil))))

(defun find-dirty-test ( o slot-name )
  (or
   (iter (for (slot-names . test) in (dirty-test o))
     (when (or (eql t slot-names)
               (member slot-name (alexandria:ensure-list slot-names)))
       (return test)))
   #'equalp))

(defun %dirty-before (new class object slot
                      &key (old-value nil old-value-provided)
                      &aux (name (closer-mop:slot-definition-name slot)))
  ;; if its not bound but has an init form, then we are in object creation
  (when (and
         *record-this-dirty-slot*     ;; dont record if updating from database
         ;; dont do this till we have correctly initialized our own slots
         (slot-boundp object 'dirty-slots)
         (slot-boundp object 'dirty-test)
         (not (member name '(dirty-slots dirty-test)))
         ;; only db-slots count for this plugin
         (member (clsql-sys::view-class-slot-db-kind slot) '(:key :base)))
    (let* ((test-fn (find-dirty-test object name))
           (old (if old-value-provided
                    old-value
                    (when (slot-boundp object name)
                      (closer-mop:slot-value-using-class class object slot))))
           (dirty? (not (funcall test-fn new old))))
      (when dirty?
        (pushnew (make-dirty-slot name old new) (dirty-slots object) :key #'slot-name)))))

(defun reset-dirty ( o )
  (setf (dirty-slots o) nil))

(defgeneric slot-dirty? ( object slot-name &key all?)
  (:documentation "determines whether or not a slot on a given object is dirty
      slot-name can be a list and all? determines if we want to not if all of
      them or dirty or if any of them are dirty")
  (:method ((o dirty-db-slots-mixin) slot-name &key (all? nil))
    (iter (for sn in (alexandria:ensure-list slot-name))
      (let ((res (find (clsql-sys::to-slot-name sn)
                       (dirty-slots o)
                       :key #'slot-name)))
        (if all?
            (always res)
            (thereis res))))))

(defmethod clsql-sys::get-slot-values-from-view :after
    ((o dirty-db-slots-mixin) slotdefs vals)
  "This setfs slot values from the database values during select, so it makes sense to reset after
   ward"
  (reset-dirty o))

(defmethod clsql-sys::update-slot-from-db-value :around ((o dirty-db-slots-mixin) slot value)
  " disable dirty slot recording if the value is from the database "
  (let ( *record-this-dirty-slot* )
    (call-next-method)))

(defmethod fill-identifier! :around ((o dirty-db-slots-mixin) &key database)
  (declare (ignore o database))
  (let ( *record-this-dirty-slot* )
    (call-next-method)))

(defmethod clsql-sys:update-instance-from-records :after
    ((o dirty-db-slots-mixin) &key &allow-other-keys)
  (reset-dirty o))

(defmethod (setf closer-mop:slot-value-using-class) :before
    (new
     (class clsql-sys::standard-db-class)
     (object dirty-db-slots-mixin)
     (slot closer-mop:standard-effective-slot-definition))
  (%dirty-before new class object slot))

(defmacro defmethod-when-possible (name args &body body)
  (when (typep (ignore-errors (fdefinition name)) 'standard-generic-function)
    `(handler-case
      ;; I dont want a broken one of these to cause the whole library to be broken.
      ;; clsql tends to lag a bit behind clsql-helper
      (defmethod ,name ,args ,@body)
      (error (c) (declare (ignorable c))
       ;; I think it is fine just ignoring the definition that doesnt work instead of
       ;; complaining
       (format *error-output* "~%warning skipping method definition: ~%~A~%" c)
       ))))

(defmethod-when-possible clsql-sys::view-classes-and-storable-slots ((object dirty-db-slots-mixin))
  ;; todo: broken for update-instance-from-record and to be removed when clsql catches up
  (let ((classes-and-slots (call-next-method)))
    (iter (for class-and-slots in classes-and-slots)
      (for defs = (iter (for slot-def in (clsql-sys::slot-defs class-and-slots))
                    (when (slot-dirty? object slot-def)
                      (collect slot-def))))
      (when defs
        (setf (clsql-sys::slot-defs class-and-slots) defs)
        (collect class-and-slots)))))

(defmethod-when-possible clsql-sys::view-classes-and-storable-slots ((object dirty-db-slots-mixin)
                                                                     &key to-database-p)
  (let ((classes-and-slots (call-next-method)))
    (if (null to-database-p)
        classes-and-slots
        ;; filter for only dirty slots on updating db
        (iter (for class-and-slots in classes-and-slots)
          (for defs = (iter (for slot-def in (clsql-sys::slot-defs class-and-slots))
                        (when (and (member (clsql-sys::view-class-slot-db-kind slot-def)
                                           '(:key :base))
                                   (slot-dirty? object slot-def))
                          (collect slot-def))))
          (when defs
            (setf (clsql-sys::slot-defs class-and-slots) defs)
            (collect class-and-slots))))))

#| reimplementation for normal classes (different metaclass)

(defclass dirty-slots-mixin ()
  ((dirty :accessor dirty :initarg :dirty :initform nil)
   (dirty-test :accessor dirty-test :initarg :dirty-test :initform `((T . ,#'equalp)))))

(defmethod (setf closer-mop:slot-value-using-class) :before
    (new
     (class standard-class)
     (object dirty-slots-mixin)
     (slot closer-mop:standard-effective-slot-definition))
  (%dirty-before new class object slot))

|#