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 (defclass msg ()
 129   ((raw :accessor msg-raw :initform nil)))
 130
 131 (defmethod initialize-instance :after ((inst msg) &key size data)
 132   (let ((obj (foreign-alloc 'c-msg)))
 133     (tg:finalize inst (lambda ()
 134                         (%msg-close obj)
 135                         (foreign-free obj)))
 136     (cond (size (%msg-init-size obj size))
 137           (data
 138            (etypecase data
 139              (string
 140               (with-foreign-string (fstr data)
 141                 (copy-lisp-string-octets
 142                  data (lambda (sz)
 143                         (%msg-init-size obj sz)
 144                         (%msg-data obj)))))
 145              ((simple-array (unsigned-byte 8))
 146               (let ((len (length data)))
 147                 (%msg-init-size obj len)
 148                 (with-pointer-to-vector-data (ptr data)
 149                   (memcpy (%msg-data obj) ptr len))))
 150              (array (progn
 151                       (%msg-init-size obj (length data))
 152                       (let ((ptr (%msg-data obj))
 153                             (i -1))
 154                         (map nil (lambda (x)
 155                                    (setf (mem-aref ptr :uchar (incf i)) x))
 156                              data))))))
 157           (t (%msg-init obj)))
 158     (setf (msg-raw inst) obj)))
 159
 160 (defun msg-data-as-is (msg)
 161   (%msg-data (msg-raw 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 (defun msg-close (msg)
 182   (%msg-close (msg-raw msg)))
 183
 184 (defun msg-init-size (msg size)
 185   (%msg-init-size (msg-raw msg) size))
 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-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-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-options flags)))
 212
 213 (defun msg-recv (s msg &rest flags)
 214   (%msg-recv (msg-raw msg) s
 215              (foreign-bitfield-value 'send-options flags)))
 216
 217 ;; Polls
 218 ;; (xxx)freiksenet: probably broken, don't use it yet.
 219
 220 (defclass pollitem ()
 221   ((raw         :accessor pollitem-raw :initform nil)
 222    (socket      :accessor pollitem-socket :initform (cffi:null-pointer) :initarg :socket)
 223    (fd          :accessor pollitem-fd :initform -1 :initarg :fd)
 224    (events      :accessor pollitem-events :initform 0 :initarg :events)
 225    (revents     :accessor pollitem-revents :initform 0)))
 226
 227 (defmethod initialize-instance :after ((inst pollitem) &key)
 228   (let ((obj (foreign-alloc 'pollitem)))
 229     (setf (pollitem-raw inst) obj)
 230     (tg:finalize inst (lambda () (foreign-free obj)))))
 231
 232 (defun poll (items &optional (timeout -1))
 233   (let ((len (length items)))
 234     (with-foreign-object (%items 'c-pollitem len)
 235       (dotimes (i len)
 236         (let ((item (nth i items))
 237               (%item (mem-aref %items 'c-pollitem i)))
 238           (with-foreign-slots ((socket fd events revents) %item pollitem)
 239             (setf socket (pollitem-socket item)
 240                   fd (pollitem-fd item)
 241                   events (pollitem-events item)))))
 242       (let ((ret (%poll %items len timeout)))
 243         (cond
 244           ((zerop ret) nil)
 245           ((plusp ret)
 246            (loop for i below len
 247               for revent = (foreign-slot-value (mem-aref %items 'c-pollitem i)
 248                                                'c-pollitem
 249                                                'revents)
 250               collect (setf (pollitem-revents (nth i items)) revent)))
 251           (t (error (convert-from-foreign (%strerror (errno)) :string))))))))
 252
 253 (defmacro with-polls (list &body body)
 254   `(let ,(loop for (name . polls) in list
 255             collect `(,name
 256                       (list
 257                        ,@(loop for (socket . events) in polls
 258                             collect `(make-instance 'pollitem
 259                                                     :socket ,socket
 260                                                     :events ,events)))))
 261      ,@body))