protocol.lisp

   1
   2 (in-package cl-ipmsg)
   3
   4 (defclass protocol ()
   5   ((udp-socket  :initform nil :accessor protocol-udp-socket)
   6    (command-to-ncommand-table :initform (make-hash-table :test #'eq)
   7                              :accessor cmd-table)
   8    (ncommand-table :initform (make-hash-table :test #'eql)
   9                   :accessor ncmd-table))
  10   )
  11
  12 (defmethod call-command-handler ((this protocol) srcaddr srcport &rest arguments)
  13   (let* ((command (getf arguments :cmd))
  14          (handler (gethash command (ncmd-table this))))
  15     (if (not handler)
  16         (format t "~&Warning: Try to execute unknown command: ~a~&arguments=~a~%"
  17                 command arguments))
  18     (when handler
  19       (apply handler (list* :hostaddr srcaddr :port srcport arguments)))))
  20
  21 (defgeneric broadcast-addr (protocol))
  22 (defgeneric analyze-message (protocol buffer))
  23 (defgeneric make-message (protocol &rest arguments))
  24
  25 (defmethod  send-command-message ((this protocol) dest port &rest arguments)
  26   (let* ((buffer (apply #'make-message (list* this arguments)))
  27          (buffer-size (length buffer)))
  28     (when (not (protocol-udp-socket this))
  29       (format t "~2&  Error: socket not initialized!~2%")
  30       (return-from send-command-message nil))
  31     #+nil(warn "DBG: ~a~&~a~&~a" port (octets-to-string buffer) buffer-size)
  32     (socket-send (protocol-udp-socket this) buffer buffer-size :port port :host dest)))
  33
  34 (defmethod  broadcast-command-message ((this protocol) port &rest arguments)
  35   #+sbcl (progn (setf (sb-bsd-sockets::sockopt-broadcast
  36                        (usocket::socket (protocol-udp-socket this))) t)
  37                 (apply #'send-command-message
  38                        (list* this (broadcast-addr this) port arguments))
  39                 (setf (sb-bsd-sockets::sockopt-broadcast
  40                        (usocket::socket (protocol-udp-socket this))) nil))
  41   )
  42
  43 (defmacro define-protocol-command-recipient
  44     (protocol name-and-aliases value param-list &body body)
  45   (let ((method-fn (gensym))
  46         (protocol-object (gensym)))
  47     `(eval-when (:load-toplevel :execute)
  48        (let ((,method-fn (lambda ,param-list ,@body))
  49              (,protocol-object (get-protocol-singleton ',protocol)))
  50          ,@(loop for cmd-name in (if (listp name-and-aliases) name-and-aliases (list name-and-aliases))
  51               collecting `(setf (gethash ,cmd-name (cmd-table ,protocol-object)) ,value))
  52          (setf (gethash ,value (ncmd-table ,protocol-object)) ,method-fn)))))
  53
  54 (defvar *protocol-singleton-table* (make-hash-table :test #'eq))
  55
  56 (defun get-protocol-singleton (class-name)
  57   (or (gethash class-name *protocol-singleton-table*)
  58       (setf (gethash class-name *protocol-singleton-table*)
  59             (make-instance class-name))))