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-string (msg)
 164   (let ((data (%msg-data (msg-raw msg)))
 165         (size (%msg-size (msg-raw msg))))
 166     (unless (zerop (pointer-address data))
 167       (foreign-string-to-lisp data :count size))))
 168
 169 (defun msg-data-as-array (msg)
 170   (let ((data (%msg-data (msg-raw msg))))
 171     (unless (zerop (pointer-address data))
 172       (let* ((len (msg-size msg))
 173              (arr (#+lispworks sys:in-static-area
 174                                #-lispworks cl:identity
 175                                (make-array len :element-type '(unsigned-byte 8)))))
 176         (declare (type (simple-array (unsigned-byte 8)) arr))
 177         (with-pointer-to-vector-data (ptr arr)
 178           (%memcpy ptr data len))
 179         arr))))
 180
 181 ;;; (xxx)freiksenet: doing zmq operations on closed message sends SBCL to ldb.
 182 (defun msg-close (msg)
 183   (tg:cancel-finalization msg)
 184   (%msg-close (msg-raw msg))
 185   (foreign-free (msg-raw msg)))
 186
 187 (defun msg-size (msg)
 188   (%msg-size (msg-raw msg)))
 189
 190 (defun msg-move (dst src)
 191   (%msg-move (msg-raw dst) (msg-raw src)))
 192
 193 (defun msg-copy (dst src)
 194   (%msg-copy (msg-raw dst) (msg-raw src)))
 195
 196 ;; Sending and recieving
 197
 198 (defun send (s data &rest flags)
 199   (with-foreign-string ((buf len) data)
 200     (%send s buf (1- len)
 201            (foreign-bitfield-value 'send-recv-options flags))))
 202
 203 (defun recv (s length &rest flags)
 204   (with-foreign-string ((buf len) (make-string length))
 205     (%recv s buf (1- len)
 206            (foreign-bitfield-value 'send-recv-options flags))
 207     (foreign-string-to-lisp buf)))
 208
 209 (defun msg-send (s msg &rest flags)
 210   (%msg-send (msg-raw msg) s
 211              (foreign-bitfield-value 'send-recv-options flags)))
 212
 213 (defun msg-recv (s msg &rest flags)
 214   (%msg-recv (msg-raw msg) s
 215              (foreign-bitfield-value 'send-recv-options flags)))
 216
 217 ;; Polls
 218
 219 (defun poll (sockets &optional timeout)
 220   (let* ((length (length sockets))
 221          (pollitems (foreign-alloc 'c-pollitem :count length)))
 222     (dotimes (i length)
 223       (apply #'fill-pollitem
 224              (mem-aref pollitems 'c-pollitem i)
 225              (nth i sockets)))
 226     (let* ((result (call-with-error-check
 227                     #'%poll
 228                     (list pollitems
 229                           length
 230                           (or timeout -1))))
 231            (events (extract-pollitems-events pollitems length)))
 232       (foreign-free pollitems)
 233       (values result events))))
 234
 235 (defun fill-pollitem (pollitem s &rest flags)
 236   (if (numberp s)
 237       (setf (foreign-slot-value pollitem 'c-pollitem 'fd)
 238             s)
 239       (setf (foreign-slot-value pollitem 'c-pollitem 'socket)
 240             s))
 241   (setf (foreign-slot-value pollitem 'c-pollitem 'events)
 242         (foreign-bitfield-value 'event-types
 243                                 flags))
 244   pollitem)
 245
 246 (defun extract-pollitems-events (pollitems length)
 247   (let ((result ()))
 248     (dotimes (i length)
 249       (push (extract-pollitem-events (mem-aref pollitems 'c-pollitem i))
 250             result))
 251     result))
 252
 253 (defun extract-pollitem-events (pollitem)
 254   (let ((socket (foreign-slot-value pollitem 'c-pollitem 'socket))
 255         (fd (foreign-slot-value pollitem 'c-pollitem 'fd))
 256         (revents (foreign-slot-value pollitem 'c-pollitem 'revents)))
 257     (cons (if (> fd 0)
 258               fd
 259               socket)
 260           (foreign-bitfield-symbols 'event-types revents))))