cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

more on tracking:save, +track-equal check

Browse source
This commit is contained in:
Helmut Merz 2024-08-04 10:07:20 +02:00
parent 75fe19b269
commit 5678483a50
1 changed files with 24 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
storage/tracking.lisp
View file

@ -66,39 +66,50 @@
(force-insert (force-insert-when cont)))
(if (eql force-insert :always)
(insert track)
(let* ((new-data (shape:data track))
(found (query-last cont (shape:head-plist track))))
(if (null found)
(insert track new-data)
(unless (util:plist-equal (shape:data found) new-data)
(let ((found (query-last cont (shape:head-plist track))))
(if found
(if (track-equal found track)
found
(if (eql force-insert :changed)
(insert track new-data)
(update track new-data))))))))
(insert track)
(progn
(unless (timestamp track)
(setf (timestamp track) (timestamp found)))
(update track)
(setf (trackid track) (trackid found))
track)))
(insert track))))))
(defun insert (track &optional data)
(defun insert (track)
(ensure-timestamp track)
(let* ((cont (container track))
(st (storage cont))
(table (storage:qualified-table-name st (table-name cont)))
(res (car (storage:query st
(sxql:insert-into table
(apply #'sxql:make-clause ':set= (plist track data))
(apply #'sxql:make-clause ':set= (plist track))
(sxql:returning :trackid))))))
(setf (trackid track) (cadr res))
track))
(defun update (track &optional data)
(defun update (track)
(ensure-timestamp track)
(let* ((cont (container track))
(st (storage cont))
(table (storage:qualified-table-name st (table-name cont))))
(storage:do-sql st
(sxql:update table
(apply #'sxql:make-clause ':set= (plist track data))
(apply #'sxql:make-clause ':set= (plist track))
(where (:= :trackid (trackid track)))))))
;;;; auxiliary functions for queries, ...
(defun track-equal (old new)
(if (timestamp new)
(unless (equal (timestamp new) (timestamp old))
(return-from track-equal nil)))
(util:plist-equal (shape:data old) (shape:data new)))
(defun setup-select (cont crit &key order-by limit)
(let ((table (storage:qualified-table-name (storage cont) (table-name cont)))
(cols (cons :trackid (append (item-head-fields cont) '(:timestamp :data))))
@ -144,9 +155,9 @@
(if (not (timestamp track))
(setf (timestamp track) (get-universal-time))))
(defun plist (track &optional data)
(defun plist (track)
(let ((vl (shape:head-plist track))
(data (or data (shape:data track))))
(data (shape:data track)))
(with-slots ((trid trackid) (ts timestamp)) track
(when trid (setf (getf vl :trackid) trid))
(when ts (setf (getf vl :timestamp) (timestamp-to-sql track ts)))