...
[cl-zmq.git] / src / zeromq-api.lisp
blob75d74ff53d35f0b2a2b2d0e52b4b06d13fe4268a
1 ;; This file is part of CL-ZMQ.
3 (in-package :zeromq)
5 ;; Basics
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))))
17 ;; Contexts
19 (defmacro with-context ((context) &body body)
20 `(let ((,context (ctx-new)))
21 (unwind-protect
22 (progn ,@body)
23 (ctx-destroy ,context))))
25 (defun ctx-get (context option)
26 (%ctx-get context
27 (foreign-enum-value
28 'context-options
29 option)))
31 (defun ctx-set (context option value)
32 (%ctx-set context
33 (foreign-enum-value
34 'context-options
35 option)
36 value))
38 ;; Sockets
40 (defun socket (context type)
41 (%socket context
42 (foreign-enum-value 'socket-types type)))
44 (defmacro with-socket ((socket context type) &body body)
45 `(let ((,socket (socket ,context ,type)))
46 (unwind-protect
47 (progn ,@body)
48 (close ,socket))))
50 (defun bind (s address)
51 (with-foreign-string (addr address)
52 (call-with-error-check #'%bind (list s addr))))
54 (defun unbind (s address)
55 (with-foreign-string (addr address)
56 (call-with-error-check #'unbind (list s addr))))
58 (defun connect (s address)
59 (with-foreign-string (addr address)
60 (call-with-error-check #'%connect (list s addr))))
62 (defun disconnect (s address)
63 (with-foreign-string (addr address)
64 (call-with-error-check #'%connect (list s addr))))
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)))
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)))))
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))))))
103 ;; Messages
105 (defclass msg ()
106 ((raw :accessor msg-raw :initform nil)))
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)))
137 (defun msg-data-as-is (msg)
138 (%msg-data (msg-raw msg)))
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))))
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))))
158 (defun msg-close (msg)
159 (%msg-close (msg-raw msg)))
161 (defun msg-init-size (msg size)
162 (%msg-init-size (msg-raw msg) size))
164 (defun msg-size (msg)
165 (%msg-size (msg-raw msg)))
167 (defun msg-move (dst src)
168 (%msg-move (msg-raw dst) (msg-raw src)))
170 (defun msg-copy (dst src)
171 (%msg-copy (msg-raw dst) (msg-raw src)))
173 ;; Sending and recieving
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))))
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)))
186 (defun msg-send (s msg &rest flags)
187 (%msg-send (msg-raw msg) s
188 (foreign-bitfield-value 'send-options flags)))
190 (defun msg-recv (s msg &rest flags)
191 (%msg-recv (msg-raw msg) s
192 (foreign-bitfield-value 'send-options flags)))
194 ;; Polls
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)))
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)))))
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))))))))
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))