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