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

shape: get and set individual head values

Browse source
This commit is contained in:
Helmut Merz 2024-08-08 10:20:15 +02:00
parent e92bc4d8a7
commit d673f6280c
2 changed files with 17 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
shape/shape.lisp
View file

@ -3,7 +3,7 @@
(defpackage :scopes/shape
(:use :common-lisp)
(:local-nicknames (:util :scopes/util))
(:export #:record #:head-fields #:head #:data
(:export #:record #:head-fields #:head #:head-value #:data
#:head-plist))
(in-package :scopes/shape)
@ -17,6 +17,12 @@
(defmethod initialize-instance :after ((rec record) &key head &allow-other-keys)
(setf (slot-value rec 'head) (util:rfill (head-fields rec) head)))
(defun head-value (rec key)
(elt (head rec) (position key (head-fields rec))))
(defun (setf head-value) (val rec key)
(setf (elt (head rec) (position key (head-fields rec))) val))
(defun head-plist (rec)
(let (pl (hv (head rec)))
(dolist (hf (head-fields rec))

10
test/test-core.lisp
View file

@ -56,17 +56,27 @@
(test-util)
(core:setup-services)
(setf (receiver t:*test-suite*) (core:find-service :test-receiver))
(test-record)
(test-send))
(core:shutdown)
(check-expected)
(t:show-result))))
(deftest test-util ()
(== (util:rfill '(1 2 3 4 5) '(a b c)) '(a b c nil nil))
(== (util:rtrim '(1 2 nil 3 nil)) '(1 2 nil 3))
(== (util:to-keyword "hello-kitty") :hello-kitty)
(== (util:loop-plist '(:a "a" :b "b") k v collect (string-upcase k)) '("A" "B"))
(== (util:plist-pairs '(:a "a" :b "b")) '((:a "a") (:b "b"))))
(deftest test-record ()
(let ((rec (make-instance 'shape:record :head '(:t1))))
(== (shape:head rec) '(:t1 nil))
(== (shape:head-value rec :taskid) :t1)
(setf (shape:head-value rec :username) :u1)
(== (shape:head-value rec :username) :u1)
))
(deftest test-send ()
(let ((rcvr (receiver t:*test-suite*))
(msg (message:create '(:test :dummy) :data "dummy payload"))