diff --git a/core/core.lisp b/core/core.lisp index 0cf988d..c449fed 100644 --- a/core/core.lisp +++ b/core/core.lisp @@ -2,7 +2,8 @@ (defpackage :scopes/core (:use :common-lisp) - (:local-nicknames (:config :scopes/config)) + (:local-nicknames (:config :scopes/config) + (:message :scopes/core/message)) (:export #:config #:service-config #:context #:name #:actions #:send #:action-spec @@ -21,11 +22,13 @@ ;;;; actions (defclass action-spec () - ((pattern :initarg :pattern :initform nil) + ((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))) @@ -33,11 +36,24 @@ (defgeneric send (rcvr msg) (:method ((rcvr context) msg) (let* ((acts (actions rcvr)) - (selected (car acts))) - (dolist (hdlr (handlers selected)) + (hdlrs (select msg acts))) + (dolist (hdlr hdlrs) (funcall hdlr rcvr msg))))) -(defvar *context* nil) +(defun select (msg acts) + (let ((h (message:head-as-list msg)) + (hdlrs nil)) + (dolist (a acts) + (if (match (pattern a) h) + (dolist (hdlr (handlers a)) + (push hdlr hdlrs)))) + hdlrs)) + +(defun match (pat h) + (dolist (item pat) + (if (and item (not (eq item (pop h)))) + (return-from match nil))) + t) ;;;; simple printer service diff --git a/core/message.lisp b/core/message.lisp index 40fcabc..6f7e11a 100644 --- a/core/message.lisp +++ b/core/message.lisp @@ -2,14 +2,11 @@ (defpackage :scopes/core/message (:use :common-lisp) - (:local-nicknames (:core :scopes/core)) (:export #:message #:simple-message #:head #:data #:head-as-list)) (in-package :scopes/core/message) -(defgeneric as-list (obj)) - ;;;; message-head (defclass message-head () @@ -32,12 +29,12 @@ (setf (slot-value h sl) (pop head-vals))) (make-instance 'message :head h :data data))) -(defmethod head-as-list ((msg message)) - (with-slots (domain action class item) (head msg) - (list domain action class item))) - (defmethod print-object ((msg message) stream) (with-slots (domain action class item) (head msg) (format stream ">" domain action class item (data msg)))) + +(defun head-as-list (msg) + (with-slots (domain action class item) (head msg) + (list domain action class item))) diff --git a/scopes-core.asd b/scopes-core.asd index 033c7d3..dc8bef2 100644 --- a/scopes-core.asd +++ b/scopes-core.asd @@ -6,10 +6,13 @@ :version "0.0.1" :homepage "https://www.cyberconcepts.org" :description "Core packages of the scopes project." - :depends-on (:alexandria :cl-dotenv :com.inuoe.jzon :local-time :log4cl :str) + :depends-on (:alexandria :cl-dotenv :com.inuoe.jzon + :local-time :log4cl :str) :components ((:file "config" :depends-on ("util")) - (:file "core/core" :depends-on ("config" "forge/forge" "util")) - (:file "core/message" :depends-on ("core/core")) + (:file "core/core" + :depends-on ("core/message" "config" + "forge/forge" "util")) + (:file "core/message") (:file "forge/forge") (:file "util") (:file "testing" :depends-on ("util")) diff --git a/scopes.asd b/scopes.asd index 0c1e5c1..8729285 100644 --- a/scopes.asd +++ b/scopes.asd @@ -9,8 +9,10 @@ :depends-on (:alexandria :chanl :cl-dotenv :com.inuoe.jzon :dbi :local-time :log4cl :str :sxql) :components ((:file "config" :depends-on ("util")) - (:file "core/core" :depends-on ("config" "forge/forge" "util")) - (:file "core/message" :depends-on ("core/core")) + (:file "core/core" + :depends-on ("core/message" "config" + "forge/forge" "util")) + (:file "core/message") (:file "forge/forge") (:file "storage/storage") (:file "storage/tracking" :depends-on ("storage/storage")) @@ -20,7 +22,8 @@ (:file "test/test-core" :depends-on ("testing" "core/core")) (:file "test/test-forge" :depends-on ("testing" "forge/forge")) (:file "test/test-storage" - :depends-on ("testing" "storage/storage" "storage/tracking"))) + :depends-on ("testing" + "storage/storage" "storage/tracking"))) :long-description "scopes: generic data processing facilities." ;;#.(uiop:read-file-string ;; (uiop:subpathname *load-pathname* "README.md"))) diff --git a/test/test-core.lisp b/test/test-core.lisp index 837747a..d087480 100644 --- a/test/test-core.lisp +++ b/test/test-core.lisp @@ -15,9 +15,9 @@ (defvar *config* nil) -;;;; core/testing +;;;; core/testing: test-receiver -(defclass test-rcvr (core:context) +(defclass test-receiver (core:context) ((core:name :initform :test-rcvr) (core:actions :initform (list @@ -49,8 +49,7 @@ (defclass test-suite (t:test-suite) ((receiver :reader receiver - ;:initform (core:printer :test-rcvr)))) - :initform (make-instance 'test-rcvr)))) + :initform (make-instance 'test-receiver)))) (defun run () (let ((*config* nil)