72 lines
2.2 KiB
Common Lisp
72 lines
2.2 KiB
Common Lisp
;;;; cl-scopes/test-core - testing for the scopes-core system.
|
|
|
|
(defpackage :scopes/test-core
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:alx :alexandria)
|
|
(:config :scopes/config)
|
|
(:core :scopes/core)
|
|
(:message :scopes/core/message)
|
|
(:util :scopes/util)
|
|
(:t :scopes/testing))
|
|
(:export #:run #:user #:password)
|
|
(:import-from :scopes/testing #:deftest #:==))
|
|
|
|
(in-package :scopes/test-core)
|
|
|
|
(defvar *config* nil)
|
|
|
|
;;;; core/testing
|
|
|
|
(defclass test-rcvr (core:context)
|
|
((core:name :initform :test-rcvr)
|
|
(core:actions
|
|
:initform (list
|
|
(make-instance 'core:action-spec
|
|
:handlers (list #'check-message))))
|
|
(expected :accessor expected
|
|
:initform (make-hash-table :test #'equalp))))
|
|
|
|
(defun check-message (ctx msg)
|
|
(let ((key (message:as-list (message:head msg))))
|
|
(multiple-value-bind (val found) (gethash key (expected ctx))
|
|
(if found
|
|
(progn
|
|
(if (not (equalp (message:data msg) val))
|
|
(t:failure "data mismatch: ~s, expected: ~s" msg val))
|
|
(remhash key (expected ctx)))
|
|
(t:failure "unexpected: ~s" msg)))))
|
|
|
|
(defun expect (ctx 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
|
|
(t:failure "unused messages: ~s" exp))))
|
|
|
|
;;;; test runner
|
|
|
|
(defclass test-suite (t:test-suite)
|
|
((receiver :reader receiver
|
|
;:initform (core:printer :test-rcvr))))
|
|
:initform (make-instance 'test-rcvr))))
|
|
|
|
(defun run ()
|
|
(let ((*config* nil)
|
|
(t:*test-suite* (make-instance 'test-suite :name "core")))
|
|
(load (t:test-path "config-core" "etc"))
|
|
(test-send)
|
|
(check-expected)
|
|
(t:show-result)))
|
|
|
|
(t:deftest test-send ()
|
|
(let ((rcvr (receiver t:*test-suite*))
|
|
(msg (message:simple-message :test :dummy))
|
|
(msg-exp (message:simple-message :test :dummy)))
|
|
(setf (message:data msg) "dummy payload")
|
|
(setf (message:data msg-exp) "dummy payload")
|
|
(expect rcvr msg-exp)
|
|
(== (core:name rcvr) :test-rcvr)
|
|
(core:send rcvr msg)
|
|
))
|