84 lines
2 KiB
Common Lisp
84 lines
2 KiB
Common Lisp
;;;; cl-scopes/core - here comes the real action
|
|
|
|
(defpackage :scopes/core
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:config :scopes/config)
|
|
(:message :scopes/core/message))
|
|
(:export #:config #:service-config
|
|
#:context #:name #:actions #:add-action #:send
|
|
#:action-spec
|
|
#:printer))
|
|
|
|
(in-package :scopes/core)
|
|
|
|
;;;; config
|
|
|
|
(defclass config (config:root)
|
|
(services))
|
|
|
|
(defclass service-config (config:base)
|
|
(start))
|
|
|
|
;;;; actions
|
|
|
|
(defclass action-spec ()
|
|
((pattern :reader pattern :initarg :pattern :initform nil)
|
|
(handlers :reader handlers :initarg :handlers)))
|
|
|
|
(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))
|
|
;(nreverse hdlrs)))
|
|
|
|
(defun match (pat h)
|
|
(dolist (item pat)
|
|
(if (and item (not (eq item (pop h))))
|
|
(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)
|
|
(declare (ignore ctx))
|
|
(format t "~&~s~%" msg))
|
|
|
|
(defclass printer (context)
|
|
((actions :initform
|
|
(list (make-instance 'action-spec
|
|
:handlers (list #'do-print))))))
|
|
|
|
(defun printer (name)
|
|
(make-instance 'printer :name name))
|