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

provide 'print-slots'; work in progress: record (item) meta information

Browse source
This commit is contained in:
Helmut Merz 2024-10-11 07:59:59 +02:00
parent fe63d977f6
commit d0c990fe7b
4 changed files with 19 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
core/message.lisp
View file

@ -18,4 +18,4 @@
(make-instance 'message :head head :data data :sender sender)) (make-instance 'message :head head :data data :sender sender))
(defmethod print-object ((msg message) stream) (defmethod print-object ((msg message) stream)
(shape:print-fields msg stream 'shape:head 'sender 'shape:data)) (shape:print-slots msg stream 'shape:head 'sender 'shape:data))

9
shape/shape.lisp
View file

@ -3,7 +3,7 @@
(defpackage :scopes/shape (defpackage :scopes/shape
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:util :scopes/util)) (:local-nicknames (:util :scopes/util))
(:export #:record #:print-fields (:export #:record #:print-fields #:print-slots
#:head-fields #:head #:head-value #:head-plist #:head-fields #:head #:head-value #:head-plist
#:data-fields #:data #:data-value)) #:data-fields #:data #:data-value))
@ -28,6 +28,13 @@
(print-unreadable-object (rec stream :type t) (print-unreadable-object (rec stream :type t)
(apply #'format stream fm (mapcar #'(lambda (x) (funcall x rec)) fields))))) (apply #'format stream fm (mapcar #'(lambda (x) (funcall x rec)) fields)))))
(defun print-slots (rec stream &rest fields)
(let ((fm (util:make-vars-format fields)))
(print-unreadable-object (rec stream :type t)
(apply #'format stream fm
(mapcar #'(lambda (x) (when (slot-boundp rec x) (slot-value rec x)))
fields)))))
(defun head-value (rec key) (defun head-value (rec key)
(elt (head rec) (position key (head-fields rec)))) (elt (head rec) (position key (head-fields rec))))

3
storage/msgstore.lisp
View file

@ -10,7 +10,8 @@
(in-package :scopes/storage/msgstore) (in-package :scopes/storage/msgstore)
(defclass pmsg (message:message tracking:track) ()) (defclass pmsg (message:message tracking:track)
((shape:head-fields :initform '(:domain :action :class :item) :allocation :class)))
(defun indexes (cont) (defun indexes (cont)
'((domain action class item) (domain class item))) '((domain action class item) (domain class item)))

9
storage/tracking.lisp
View file

@ -7,7 +7,8 @@
(:storage :scopes/storage) (:storage :scopes/storage)
(:util :scopes/util) (:util :scopes/util)
(:alx :alexandria) (:alx :alexandria)
(:jzon :com.inuoe.jzon)) (:jzon :com.inuoe.jzon)
(:mop :closer-mop))
(:export #:track #:trackid #:id-str #:key-fields #:timestamp (:export #:track #:trackid #:id-str #:key-fields #:timestamp
#:container #:make-container #:table-name #:storage #:make-item #:container #:make-container #:table-name #:storage #:make-item
#:get-track #:query-last #:query-one #:query #:make-where #:get-track #:query-last #:query-one #:query #:make-where
@ -61,8 +62,12 @@
(make-instance 'container :short-name :trk :storage st)) (make-instance 'container :short-name :trk :storage st))
(defmethod initialize-instance :after ((cont container) &key &allow-other-keys) (defmethod initialize-instance :after ((cont container) &key &allow-other-keys)
(let ((ic (find-class (item-class cont))))
(setf (gethash (short-name cont) *containers*) cont) (setf (gethash (short-name cont) *containers*) cont)
(setf (item-head-fields cont) (shape:head-fields (make-instance (item-class cont))))) ;(mop:ensure-finalized ic)
;(setf (item-head-fields cont)
; (shape:head-fields (mop:class-prototype ic)))))
(setf (item-head-fields cont) (shape:head-fields (make-instance ic)))))
(defun make-item (cont &rest head) (defun make-item (cont &rest head)
(make-instance (item-class cont) :head head :container cont)) (make-instance (item-class cont) :head head :container cont))