core: context: add-action

core/core.lisp

@@ -5,7 +5,7 @@
   (:local-nicknames (:config :scopes/config)
                     (:message :scopes/core/message))
   (:export #:config #:service-config
-           #:context #:name #:actions #:send
+           #:context #:name #:actions #:add-action #:send
            #:action-spec
            #:printer))
 
@@ -25,21 +25,6 @@
   ((pattern :reader pattern :initarg :pattern :initform nil)
    (handlers :reader handlers :initarg :handlers)))
 
-;;;; context
-
-(defvar *context* nil)
-
-(defclass context () 
-  ((name :reader name :initarg :name)
-   (actions :accessor actions :initform nil)))
-
-(defgeneric send (rcvr msg)
-  (:method ((rcvr context) msg)
-    (let* ((acts (actions rcvr))
-           (hdlrs (select msg acts)))
-      (dolist (hdlr hdlrs)
-        (funcall hdlr rcvr msg)))))
-
 (defun select (msg acts)
   (let ((h (message:head-as-list msg))
         (hdlrs nil))
@@ -48,6 +33,7 @@
         (dolist (hdlr (handlers a))
           (push hdlr hdlrs))))
     hdlrs))
+    ;(nreverse hdlrs)))
 
 (defun match (pat h)
   (dolist (item pat)
@@ -55,6 +41,34 @@
       (return-from match nil)))
   t)
 
+(defun find-action (pat acts)
+  (dolist (a acts)
+    (if (equal (pattern a) pat)
+      (return-from find-action a))))
+
+;;;; context
+
+(defvar *context* nil)
+
+(defclass context () 
+  ((name :reader name :initarg :name)
+   (actions :accessor actions :initform nil)))
+
+(defun add-action (ctx pat hdlr)
+  (let* ((acts (actions ctx))
+         (act (find-action pat acts)))
+    (if act
+      (push hdlr (handlers act))
+      (push (make-instance 'action-spec :pattern pat :handlers (list hdlr)) 
+            (actions ctx)))))
+
+(defgeneric send (rcvr msg)
+  (:method ((rcvr context) msg)
+    (let* ((acts (actions rcvr))
+           (hdlrs (select msg acts)))
+      (dolist (hdlr hdlrs)
+        (funcall hdlr rcvr msg)))))
+
 ;;;; simple printer service
 
 (defun do-print (ctx msg)

test/test-core.lisp

@@ -19,10 +19,6 @@
 
 (defclass test-receiver (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))))
 
@@ -52,9 +48,11 @@
              :initform (make-instance 'test-receiver))))
 
 (defun run ()
-  (let ((*config* nil)
-        (t:*test-suite* (make-instance 'test-suite :name "core")))
+  (let* ((*config* nil)
+         (t:*test-suite* (make-instance 'test-suite :name "core"))
+         (rcvr (receiver t:*test-suite*)))
     (load (t:test-path "config-core" "etc"))
+    (core:add-action rcvr '(:test) #'check-message)
     (test-send)
     (check-expected)
     (t:show-result)))