From bfa96254a3060de7ff98217f522acd7ee693e733 Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Fri, 30 Jan 2026 15:45:06 +0100
Subject: [PATCH] shape: add head-update function, e.g. for creating new
 message heads

---
 core/core.lisp            |  7 ++++---
 shape/shape.lisp          | 14 +++++++++++---
 test/etc/config-core.lisp |  3 ++-
 test/test-core.lisp       |  4 +++-
 4 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/core/core.lisp b/core/core.lisp
index 662052c..3370b02 100644
--- a/core/core.lisp
+++ b/core/core.lisp
@@ -141,12 +141,13 @@
         (actor:send cust new-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
     (util:lgw "empty receivers list" msg)
     (return-from forward))
-  (let* ((h (shape:head msg))
-         (new-msg (message:create `(,domain ,action ,@(cddr h))
+  (let* ((h (shape:head-update
+              msg :domain domain :action action :class class :item item))
+         (new-msg (message:create h
                                   :data (shape:data msg)
                                   :customer (actor:customer msg))))
     (dolist (rcvname receivers)
diff --git a/shape/shape.lisp b/shape/shape.lisp
index 2edb527..e37a630 100644
--- a/shape/shape.lisp
+++ b/shape/shape.lisp
@@ -6,7 +6,7 @@
                     (:mop :closer-mop))
   (:export #:meta #:get-meta #:create #:record-meta
            #: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))
 
 (in-package :scopes/shape)
@@ -52,12 +52,20 @@
 (defun (setf head-value) (val rec key)
   (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)))
     (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))
 
+(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)
   (getf (data rec) key))
 
diff --git a/test/etc/config-core.lisp b/test/etc/config-core.lisp
index 9e46a8f..0584556 100644
--- a/test/etc/config-core.lisp
+++ b/test/etc/config-core.lisp
@@ -16,4 +16,5 @@
 (config:add :forwarder :setup (core:make-setup))
 (config:add-action '(:test)
   (lambda (ctx msg)
-    (core:forward ctx msg :receivers '(:test-receiver))))
+    (core:forward ctx msg :receivers '(:test-receiver)
+                  :domain :scopes :action :forward)))
diff --git a/test/test-core.lisp b/test/test-core.lisp
index 86aa80a..b137dc0 100644
--- a/test/test-core.lisp
+++ b/test/test-core.lisp
@@ -114,7 +114,9 @@
     (== (shape:head rec) '(:t1 nil))
     (== (shape:head-value rec :taskid) :t1)
     (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 ()
   (let ((mb (async:make-task nil)))