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