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

tracking:save: use - optionally restricted - key-fields instead of all head-fields for query

Browse source
This commit is contained in:
Helmut Merz 2024-08-07 09:42:52 +02:00
parent a3238f4c2c
commit ca7c4a824e
3 changed files with 22 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
storage/tracking.lisp
View file

@ -21,10 +21,21 @@
(defvar *build-track-data* #'alx:hash-table-plist) (defvar *build-track-data* #'alx:hash-table-plist)
(defclass track (shape:record) (defclass track (shape:record)
((trackid :accessor trackid :initform nil) ((key-fields :reader key-fields :initarg :key-fields :initform nil :allocation :class)
(trackid :accessor trackid :initform nil)
(timestamp :accessor timestamp :initform nil) (timestamp :accessor timestamp :initform nil)
(container :reader container :initarg :container))) (container :reader container :initarg :container)))
(defun keys-plist (rec)
(let ((kf (key-fields rec))
(hv (shape:head-plist rec)))
(if kf
(util:filter-plist hv kf)
hv)))
(defun uid (tr)
(format nil "~(~a~)-~a" (short-name (container tr)) (trackid tr)))
(defun timestamp-to-sql (tr ts) (defun timestamp-to-sql (tr ts)
(funcall (getf (storage:params (storage (container tr))) :ts-sql) ts)) (funcall (getf (storage:params (storage (container tr))) :ts-sql) ts))
@ -77,7 +88,8 @@
(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 ((found (query-last cont (shape:head-plist track)))) ;(let ((found (query-last cont (shape:head-plist track))))
(let ((found (query-last cont (keys-plist track))))
(if found (if found
(if (track-equal found track) (if (track-equal found track)
found found

3
test/test-storage.lisp
View file

@ -84,8 +84,9 @@
(deftest test-folder (ctx) (deftest test-folder (ctx)
(let ((st (storage:storage ctx)) (let ((st (storage:storage ctx))
(data (make-hash-table)) (data (make-hash-table))
cont f1 f2 f3) cont root f1 f2 f3)
(setf cont (folder:make-container st)) (setf cont (folder:make-container st))
(storage:drop-table st :folders) (storage:drop-table st :folders)
(tracking:create-table cont) (tracking:create-table cont)
;(setf root (folder:root))
)) ))

7
util.lisp
View file

@ -3,7 +3,7 @@
(defpackage :scopes/util (defpackage :scopes/util
(:use :common-lisp) (:use :common-lisp)
(:export #:lg #:lgd #:lgi (:export #:lg #:lgd #:lgi
#:rtrim #:loop-plist #:plist-pairs #:plist-equal #:rtrim #:loop-plist #:filter-plist #:plist-pairs #:plist-equal
#:flatten-str #:to-keyword #:keyword-to-string #:to-string #:flatten-str #:to-keyword #:keyword-to-string #:to-string
#:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string #:absolute-dir #:check-dir #:ensure-dir #:home-path #:path-from-string
#:relative-path #:runtime-path #:system-path)) #:relative-path #:runtime-path #:system-path))
@ -26,10 +26,15 @@
(defmacro loop-plist (plist kvar vvar &body body) (defmacro loop-plist (plist kvar vvar &body body)
`(loop for (,kvar ,vvar . nil) on ,plist by #'cddr ,@body)) `(loop for (,kvar ,vvar . nil) on ,plist by #'cddr ,@body))
(defun filter-plist (pl keys)
(loop-plist pl k v when (find k keys) collect v))
(defun plist-pairs (pl) (defun plist-pairs (pl)
(loop-plist pl k v collect (list k v))) (loop-plist pl k v collect (list k v)))
(defun plist-equal (l1 l2) (defun plist-equal (l1 l2)
(unless (= (length l1) (length l2))
(return-from plist-equal nil))
(loop-plist l1 k v do (loop-plist l1 k v do
(unless (equal (getf l2 k) v) (unless (equal (getf l2 k) v)
(return-from plist-equal nil))) (return-from plist-equal nil)))