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

test-receiver: full functionality, using head list as key in hash table

Browse source
This commit is contained in:
Helmut Merz 2024-06-15 17:14:49 +02:00
parent ed5af42f49
commit 96ebbe7d0c
2 changed files with 43 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
core/message.lisp
View file

@ -4,16 +4,33 @@
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:core :scopes/core)) (:local-nicknames (:core :scopes/core))
(:export #:message #:simple-message (:export #:message #:simple-message
#:head #:data)) #:head #:data
#:as-list))
(in-package :scopes/core/message) (in-package :scopes/core/message)
(defgeneric as-list (obj))
;;;; message-head
(defclass message-head () (defclass message-head ()
((domain) ((domain)
(action) (action)
(class) (class)
(item))) (item)))
(defmethod print-object ((head message-head) stream)
(with-slots (domain action class item) head
(format stream
"<message-head (~a ~a ~a ~a)>"
domain action class item)))
(defmethod as-list ((h message-head))
(with-slots (domain action class item) h
(list domain action class item)))
;;;; message
(defclass message () (defclass message ()
((head :reader head :initarg :head) ((head :reader head :initarg :head)
(sender) (sender)

33
test/test-core.lisp
View file

@ -2,7 +2,8 @@
(defpackage :scopes/test-core (defpackage :scopes/test-core
(:use :common-lisp) (:use :common-lisp)
(:local-nicknames (:config :scopes/config) (:local-nicknames (:alx :alexandria)
(:config :scopes/config)
(:core :scopes/core) (:core :scopes/core)
(:message :scopes/core/message) (:message :scopes/core/message)
(:util :scopes/util) (:util :scopes/util)
@ -24,13 +25,26 @@
(expected :accessor expected :initform (make-hash-table :test #'equalp)))) (expected :accessor expected :initform (make-hash-table :test #'equalp))))
(defun check-message (ctx msg) (defun check-message (ctx msg)
(multiple-value-bind (val found) (gethash (message:head msg) (expected ctx)) (let ((key (message:as-list (message:head msg))))
(if (not found) (multiple-value-bind (val found) (gethash key (expected ctx))
(push (format nil "unexpected: ~s" msg) (if found
(t:errors t:*test-suite*))))) (progn
(if (not (equalp (message:data msg) val))
(push (format nil "no matchhing data: ~s, expected: ~s" msg val)
(t:errors t:*test-suite*)))
(remhash key (expected ctx)))
(push (format nil "unexpected: ~s" msg)
(t:errors t:*test-suite*))))))
(defun expect (ctx msg) (defun expect (ctx msg)
(setf (gethash (message:head msg) (expected ctx)) (message:data msg))) (setf (gethash (message:as-list (message:head msg)) (expected ctx))
(message:data msg)))
(defun check-expected ()
(let ((exp (alx:hash-table-keys (expected (receiver t:*test-suite*)))))
(if exp
(push (format nil "unused messages: ~s" exp)
(t:errors t:*test-suite*)))))
;;;; test runner ;;;; test runner
@ -44,13 +58,16 @@
(t:*test-suite* (make-instance 'test-suite :name "core"))) (t:*test-suite* (make-instance 'test-suite :name "core")))
(load (t:test-path "config-core" "etc")) (load (t:test-path "config-core" "etc"))
(test-send) (test-send)
(check-expected)
(t:show-result))) (t:show-result)))
(t:deftest test-send () (t:deftest test-send ()
(let ((rcvr (receiver t:*test-suite*)) (let ((rcvr (receiver t:*test-suite*))
(msg (message:simple-message :test :dummy))) (msg (message:simple-message :test :dummy))
(msg-exp (message:simple-message :test :dummy)))
(setf (message:data msg) "dummy payload") (setf (message:data msg) "dummy payload")
(expect rcvr msg) (setf (message:data msg-exp) "dummy payload")
(expect rcvr msg-exp)
(== (core:name rcvr) :test-rcvr) (== (core:name rcvr) :test-rcvr)
(core:send rcvr msg) (core:send rcvr msg)
)) ))