shape: add head-update function, e.g. for creating new message heads

This commit is contained in:
Helmut Merz 2026-01-30 15:45:06 +01:00
parent 95127d94e8
commit bfa96254a3
4 changed files with 20 additions and 8 deletions

View file

@ -141,12 +141,13 @@
(actor:send cust new-msg)) (actor:send cust new-msg))
(util:lgw "customer missing" msg)))) (util:lgw "customer missing" msg))))
(defun forward (ctx msg &key receivers (domain :scopes) (action :forward)) (defun forward (ctx msg &key receivers domain action class item)
(unless receivers (unless receivers
(util:lgw "empty receivers list" msg) (util:lgw "empty receivers list" msg)
(return-from forward)) (return-from forward))
(let* ((h (shape:head msg)) (let* ((h (shape:head-update
(new-msg (message:create `(,domain ,action ,@(cddr h)) msg :domain domain :action action :class class :item item))
(new-msg (message:create h
:data (shape:data msg) :data (shape:data msg)
:customer (actor:customer msg)))) :customer (actor:customer msg))))
(dolist (rcvname receivers) (dolist (rcvname receivers)

View file

@ -6,7 +6,7 @@
(:mop :closer-mop)) (:mop :closer-mop))
(:export #:meta #:get-meta #:create #:record-meta (:export #:meta #:get-meta #:create #:record-meta
#:record #:print-fields #:print-slots #:record #:print-fields #:print-slots
#:head-fields #:head #:head-value #:head-plist #:head-fields #:head #:head-value #:head-plist #:head-update
#:data-fields #:data #:data-value)) #:data-fields #:data #:data-value))
(in-package :scopes/shape) (in-package :scopes/shape)
@ -52,12 +52,20 @@
(defun (setf head-value) (val rec key) (defun (setf head-value) (val rec key)
(setf (elt (head rec) (position key (head-fields rec))) val)) (setf (elt (head rec) (position key (head-fields rec))) val))
(defun head-plist (rec) (defun head-plist (rec &key (transform-value #'util:from-keyword))
(let (pl (hv (head rec))) (let (pl (hv (head rec)))
(dolist (hf (head-fields rec)) (dolist (hf (head-fields rec))
(setf pl (cons hf (cons (util:from-keyword (pop hv)) pl)))) (setf pl (cons hf (cons (funcall transform-value (pop hv)) pl))))
pl)) pl))
(defun head-plist-n (rec)
(loop for k in (head-fields rec) and v in (head rec) nconc (list k v)))
(defun head-update (rec &rest plst)
(reverse
(util:loop-plist (head-plist rec :transform-value #'identity) k v
collect (or (getf plst k) v))))
(defun data-value (rec key) (defun data-value (rec key)
(getf (data rec) key)) (getf (data rec) key))

View file

@ -16,4 +16,5 @@
(config:add :forwarder :setup (core:make-setup)) (config:add :forwarder :setup (core:make-setup))
(config:add-action '(:test) (config:add-action '(:test)
(lambda (ctx msg) (lambda (ctx msg)
(core:forward ctx msg :receivers '(:test-receiver)))) (core:forward ctx msg :receivers '(:test-receiver)
:domain :scopes :action :forward)))

View file

@ -114,7 +114,9 @@
(== (shape:head rec) '(:t1 nil)) (== (shape:head rec) '(:t1 nil))
(== (shape:head-value rec :taskid) :t1) (== (shape:head-value rec :taskid) :t1)
(setf (shape:head-value rec :username) :u1) (setf (shape:head-value rec :username) :u1)
(== (shape:head-value rec :username) :u1))) (== (shape:head-value rec :username) :u1)
(== (shape:head-plist rec) '(:username "u1" :taskid "t1"))
))
(deftest test-util-async () (deftest test-util-async ()
(let ((mb (async:make-task nil))) (let ((mb (async:make-task nil)))