1 ;; Copyright (c) 2009, 2010 Vitaly Mayatskikh <v.mayatskih@gmail.com>
3 ;; This file is part of 0MQ.
5 ;; 0MQ is free software; you can redistribute it and/or modify it under
6 ;; the terms of the Lesser GNU General Public License as published by
7 ;; the Free Software Foundation; either version 3 of the License, or
8 ;; (at your option) any later version.
10 ;; 0MQ is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;; Lesser GNU General Public License for more details.
15 ;; You should have received a copy of the Lesser GNU General Public License
16 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
20 ;; Stolen from CFFI. Uses custom allocator (alloc-fn) instead of foreign-alloc
21 (defun copy-lisp-string-octets (string alloc-fn
&key
(encoding cffi
::*default-foreign-encoding
*)
22 (null-terminated-p t
) (start 0) end
)
23 "Allocate a foreign string containing Lisp string STRING.
24 The string must be freed with FOREIGN-STRING-FREE."
25 (check-type string string
)
26 (cffi::with-checked-simple-vector
((string (coerce string
'babel
:unicode-string
))
27 (start start
) (end end
))
28 (declare (type simple-string string
))
29 (let* ((mapping (cffi::lookup-mapping cffi
::*foreign-string-mappings
* encoding
))
30 (count (funcall (cffi::octet-counter mapping
) string start end
0))
31 (length (if null-terminated-p
32 (+ count
(cffi::null-terminator-len encoding
))
34 (ptr (funcall alloc-fn length
)))
35 (funcall (cffi::encoder mapping
) string start end ptr
0)
36 (when null-terminated-p
37 (dotimes (i (cffi::null-terminator-len encoding
))
38 (setf (mem-ref ptr
:char
(+ count i
)) 0)))
39 (values ptr length
))))
42 ((raw :accessor msg-raw
:initform nil
)))
44 (defmethod initialize-instance :after
((inst msg
) &key size data
)
45 (let ((obj (foreign-alloc 'msg
)))
46 (tg:finalize inst
(lambda ()
49 (cond (size (%msg-init-size obj size
))
52 (string (copy-lisp-string-octets
54 (%msg-init-size obj sz
)
56 ((simple-array (unsigned-byte 8))
57 (let ((len (length data
)))
58 (%msg-init-size obj len
)
59 (with-pointer-to-vector-data (ptr data
)
60 (foreign-funcall "memcpy"
61 :pointer
(%msg-data obj
)
66 (%msg-init-size obj
(length data
))
67 (let ((ptr (%msg-data obj
))
70 (setf (mem-aref ptr
:uchar
(incf i
)) x
))
73 (setf (msg-raw inst
) obj
)))
76 ((raw :accessor pollitem-raw
:initform nil
)
77 (socket :accessor pollitem-socket
:initform nil
:initarg
:socket
)
78 (fd :accessor pollitem-fd
:initform -
1 :initarg
:fd
)
79 (events :accessor pollitem-events
:initform
0 :initarg
:events
)
80 (revents :accessor pollitem-revents
:initform
0)))
82 (defmethod initialize-instance :after
((inst pollitem
) &key
)
83 (let ((obj (foreign-alloc 'pollitem
)))
84 (setf (pollitem-raw inst
) obj
)
85 (tg:finalize inst
(lambda () (foreign-free obj
)))))
87 (defun bind (s address
)
88 (with-foreign-string (addr address
)
91 (defun connect (s address
)
92 (with-foreign-string (addr address
)
95 (defmacro with-context
((context app-threads io-threads
&optional flags
) &body body
)
96 `(let ((,context
(init ,app-threads
,io-threads
(or ,flags
0))))
100 (defmacro with-socket
((socket context type
) &body body
)
101 `(let ((,socket
(socket ,context
,type
)))
105 (defmacro with-stopwatch
(&body body
)
106 (let ((watch (gensym)))
107 `(with-foreign-object (,watch
:long
2)
108 (setq ,watch
(stopwatch-start))
110 (stopwatch-stop ,watch
))))
112 (defun msg-data-as-is (msg)
113 (%msg-data
(msg-raw msg
)))
115 (defun msg-data-as-string (msg)
116 (let ((data (%msg-data
(msg-raw msg
))))
117 (unless (zerop (pointer-address data
))
118 (convert-from-foreign data
:string
))))
120 (defun msg-data-as-array (msg)
121 (let ((data (%msg-data
(msg-raw msg
))))
122 (unless (zerop (pointer-address data
))
123 (let* ((len (msg-size msg
))
124 (arr (make-array len
:element-type
'(unsigned-byte))))
126 (setf (aref arr i
) (mem-aref data
:uchar i
)))
129 (defun send (s msg
&optional flags
)
130 (%send s
(msg-raw msg
) (or flags
0)))
132 (defun recv (s msg
&optional flags
)
133 (%recv s
(msg-raw msg
) (or flags
0)))
135 (defun msg-init-size (msg size
)
136 (%msg-init-size
(msg-raw msg
) size
))
138 (defun msg-close (msg)
139 (%msg-close
(msg-raw msg
)))
141 (defun msg-size (msg)
142 (%msg-size
(msg-raw msg
)))
144 (defun msg-move (dst src
)
145 (%msg-move
(msg-raw dst
) (msg-raw src
)))
147 (defun msg-copy (dst src
)
148 (%msg-copy
(msg-raw dst
) (msg-raw src
)))
150 (defun setsockopt (socket option value
)
152 (string (with-foreign-string (string value
)
153 (%setsockopt socket option string
(length value
))))
154 (integer (with-foreign-object (int :long
2)
155 (setf (mem-aref int
:long
0) value
)
156 (%setsockopt socket option int
(foreign-type-size :long
))))))
158 (defun poll (items &optional
(timeout -
1))
159 (let ((len (length items
)))
160 (with-foreign-object (%items
'pollitem len
)
162 (let ((item (nth i items
))
163 (%item
(mem-aref %items
'pollitem i
)))
164 (with-foreign-slots ((socket fd events revents
) %item pollitem
)
165 (setf socket
(pollitem-socket item
)
166 fd
(pollitem-fd item
)
167 events
(pollitem-events item
)))))
168 (let ((ret (%poll %items len timeout
)))
172 (loop for i below len
173 for revent
= (foreign-slot-value (mem-aref %items
'pollitem i
)
176 collect
(setf (pollitem-revents (nth i items
)) revent
)))
177 (t (error (convert-from-foreign (%strerror
*errno
*) :string
))))))))
179 (defmacro with-polls
(list &body body
)
180 `(let ,(loop for
(name . polls
) in list
183 ,@(loop for
(socket . events
) in polls
184 collect
`(make-instance 'pollitem
190 (with-foreign-objects ((major :int
)
193 (%version major minor patch
)
194 (format nil
"~d.~d.~d"
197 (mem-ref patch
:int
))))