src/zeromq-api.lisp

   1 ;; This file is part of CL-ZMQ.
   2
   3 (in-package :zeromq)
   4
   5 ;; Basics
   6
   7 (defun version ()
   8   (with-foreign-objects ((major :int)
   9                          (minor :int)
  10                          (patch :int))
  11     (%version major minor patch)
  12     (values
  13      (mem-ref major :int)
  14      (mem-ref minor :int)
  15      (mem-ref patch :int))))
  16
  17 ;; Contexts
  18
  19 (defmacro with-context ((context) &body body)
  20   `(let ((,context (ctx-new)))
  21      (unwind-protect
  22           (progn ,@body)
  23        (ctx-destroy ,context))))
  24
  25 (defun ctx-new ()
  26   (call-with-error-check
  27    #'%ctx-new '()
  28    :type :pointer))
  29
  30 (defun ctx-get (context option)
  31   (call-with-error-check
  32    #'%ctx-get
  33    (list context
  34          (foreign-enum-value
  35                'context-options
  36                option))))
  37
  38 (defun ctx-set (context option value)
  39   (call-with-error-check
  40    #'%ctx-set
  41    (list context
  42          (foreign-enum-value
  43           'context-options
  44           option)
  45          value)))
  46
  47 (defun ctx-destroy (context)
  48   (call-with-error-check
  49    #'%ctx-destroy
  50    (list context)))
  51
  52 ;; Sockets
  53
  54 (defun socket (context type)
  55   (call-with-error-check
  56    #'%socket
  57    (list context
  58          (foreign-enum-value 'socket-types
  59                              type))
  60    :type :pointer))
  61
  62 (defun close (socket)
  63   (call-with-error-check
  64    #'%close
  65    (list socket)))
  66
  67 (defmacro with-socket ((socket context type) &body body)
  68   `(let ((,socket (socket ,context ,type)))
  69      (unwind-protect
  70           (progn ,@body)
  71        (close ,socket))))
  72
  73 (defun bind (s address)
  74   (with-foreign-string (addr address)
  75     (call-with-error-check #'%bind (list s addr))))
  76
  77 (defun unbind (s address)
  78   (with-foreign-string (addr address)
  79     (call-with-error-check #'%unbind (list s addr))))
  80
  81 (defun connect (s address)
  82   (with-foreign-string (addr address)
  83     (call-with-error-check #'%connect (list s addr))))
  84
  85 (defun disconnect (s address)
  86   (with-foreign-string (addr address)
  87     (call-with-error-check #'%disconnect (list s addr))))
  88
  89 (defun get-socket-option-value-type (option)
  90   (case option
  91     ((:affinity) :uint64)
  92     ((:subscribe
  93       :unsubscribe
  94       :identity
  95       :tcp-accept-filter
  96       :last-endpoint) :string)
  97     ((:maxmsgsize) :int64)
  98     (otherwise :int)))
  99
 100 (defun getsockopt (socket option)
 101   (let ((return-type (get-socket-option-value-type option))
 102         (option-code (foreign-enum-value 'socket-options option)))
 103     (if (eq return-type :string)
 104         (with-foreign-objects ((str :char 255)
 105                                (len 'size-t))
 106           (setf (mem-aref len 'size-t) (* (foreign-type-size :char) 255))
 107           (%getsockopt socket option-code str len)
 108           (foreign-string-to-lisp str :count (mem-aref len 'size-t)))
 109         (with-foreign-objects ((obj return-type)
 110                                (len 'size-t))
 111           (setf (mem-aref len 'size-t) (foreign-type-size return-type))
 112           (%getsockopt socket option-code obj len)
 113           (mem-aref obj return-type)))))
 114
 115 (defun setsockopt (socket option value)
 116   (let ((return-type (get-socket-option-value-type option))
 117         (option-code (foreign-enum-value 'socket-options option)))
 118     (if (eq return-type :string)
 119         (with-zmq-string ((string len) value)
 120           (%setsockopt socket option-code string len))
 121         (with-foreign-object (obj return-type)
 122           (setf (mem-aref obj return-type) value)
 123           (%setsockopt socket option-code obj
 124                        (foreign-type-size return-type))))))
 125
 126 ;; Messages
 127
 128 (defstruct (msg (:constructor %make-msg))
 129   raw)
 130
 131 (defun make-msg (&key size data)
 132   (let ((msg (%make-msg))
 133         (raw-msg (foreign-alloc 'c-msg)))
 134     (tg:finalize msg (lambda ()
 135                        (%msg-close raw-msg)
 136                        (foreign-free raw-msg)))
 137     (cond (size (%msg-init-size raw-msg size))
 138           (data
 139            (etypecase data
 140              (string
 141               (with-foreign-string (fstr data)
 142                 (copy-lisp-string-octets
 143                  data
 144                  (lambda (size)
 145                    (%msg-init-size raw-msg size)
 146                    (%msg-data raw-msg)))))
 147              ((simple-array (unsigned-byte 8))
 148               (let ((len (length data)))
 149                 (%msg-init-size raw-msg len)
 150                 (with-pointer-to-vector-data (ptr data)
 151                   (%memcpy (%msg-data raw-msg) ptr len))))
 152              (array (progn
 153                       (%msg-init-size raw-msg (length data))
 154                       (let ((ptr (%msg-data raw-msg))
 155                             (i -1))
 156                         (map nil (lambda (x)
 157                                    (setf (mem-aref ptr :uchar (incf i)) x))
 158                              data))))))
 159           (t (%msg-init raw-msg)))
 160     (setf (msg-raw msg) raw-msg)
 161     msg))
 162
 163 (defun msg-data-as-is (msg)
 164   (%msg-data (msg-raw msg)))
 165
 166 (defun msg-data-as-string (msg)
 167   (let ((data (%msg-data (msg-raw msg)))
 168         (size (%msg-size (msg-raw msg))))
 169     (unless (zerop (pointer-address data))
 170       (foreign-string-to-lisp data :count size))))
 171
 172 (defun msg-data-as-array (msg)
 173   (let ((data (%msg-data (msg-raw msg))))
 174     (unless (zerop (pointer-address data))
 175       (let* ((len (msg-size msg))
 176              (arr (#+lispworks sys:in-static-area
 177                                #-lispworks cl:identity
 178                                (make-array len :element-type '(unsigned-byte 8)))))
 179         (declare (type (simple-array (unsigned-byte 8)) arr))
 180         (with-pointer-to-vector-data (ptr arr)
 181           (%memcpy ptr data len))
 182         arr))))
 183
 184 (defun msg-size (msg)
 185   (%msg-size (msg-raw msg)))
 186
 187 (defun msg-move (dst src)
 188   (%msg-move (msg-raw dst) (msg-raw src)))
 189
 190 (defun msg-copy (dst src)
 191   (%msg-copy (msg-raw dst) (msg-raw src)))
 192
 193 ;; Sending and recieving
 194
 195 (defun send (s data &rest flags)
 196   (with-foreign-string ((buf len) data)
 197     (%send s buf (1- len)
 198            (foreign-bitfield-value 'send-recv-options flags))))
 199
 200 (defun recv (s length &rest flags)
 201   (with-foreign-string ((buf len) (make-string length))
 202     (%recv s buf (1- len)
 203            (foreign-bitfield-value 'send-recv-options flags))
 204     (foreign-string-to-lisp buf)))
 205
 206 (defun msg-send (s msg &rest flags)
 207   (%msg-send (msg-raw msg) s
 208              (foreign-bitfield-value 'send-recv-options flags)))
 209
 210 (defun msg-recv (s msg &rest flags)
 211   (%msg-recv (msg-raw msg) s
 212              (foreign-bitfield-value 'send-recv-options flags)))
 213
 214 ;; Polls
 215 ;; (xxx)freiksenet: probably broken, don't use it yet.
 216
 217 (defclass pollitem ()
 218   ((raw         :accessor pollitem-raw :initform nil)
 219    (socket      :accessor pollitem-socket :initform (cffi:null-pointer) :initarg :socket)
 220    (fd          :accessor pollitem-fd :initform -1 :initarg :fd)
 221    (events      :accessor pollitem-events :initform 0 :initarg :events)
 222    (revents     :accessor pollitem-revents :initform 0)))
 223
 224 (defmethod initialize-instance :after ((inst pollitem) &key)
 225   (let ((obj (foreign-alloc 'pollitem)))
 226     (setf (pollitem-raw inst) obj)
 227     (tg:finalize inst (lambda () (foreign-free obj)))))
 228
 229 (defun poll (items &optional (timeout -1))
 230   (let ((len (length items)))
 231     (with-foreign-object (%items 'c-pollitem len)
 232       (dotimes (i len)
 233         (let ((item (nth i items))
 234               (%item (mem-aref %items 'c-pollitem i)))
 235           (with-foreign-slots ((socket fd events revents) %item pollitem)
 236             (setf socket (pollitem-socket item)
 237                   fd (pollitem-fd item)
 238                   events (pollitem-events item)))))
 239       (let ((ret (%poll %items len timeout)))
 240         (cond
 241           ((zerop ret) nil)
 242           ((plusp ret)
 243            (loop for i below len
 244               for revent = (foreign-slot-value (mem-aref %items 'c-pollitem i)
 245                                                'c-pollitem
 246                                                'revents)
 247               collect (setf (pollitem-revents (nth i items)) revent)))
 248           (t (error (convert-from-foreign (%strerror (errno)) :string))))))))
 249
 250 (defmacro with-polls (list &body body)
 251   `(let ,(loop for (name . polls) in list
 252             collect `(,name
 253                       (list
 254                        ,@(loop for (socket . events) in polls
 255                             collect `(make-instance 'pollitem
 256                                                     :socket ,socket
 257                                                     :events ,events)))))
 258      ,@body))