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