summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--bindings/cl/zeromq-api.lisp59
1 files changed, 41 insertions, 18 deletions
diff --git a/bindings/cl/zeromq-api.lisp b/bindings/cl/zeromq-api.lisp
index 953b98b..188bdd4 100644
--- a/bindings/cl/zeromq-api.lisp
+++ b/bindings/cl/zeromq-api.lisp
@@ -17,28 +17,51 @@
(in-package :zeromq)
+;; Stolen from CFFI. Uses custom allocator (alloc-fn) instead of foreign-alloc
+(defun copy-lisp-string-octets (string alloc-fn &key (encoding cffi::*default-foreign-encoding*)
+ (null-terminated-p t) (start 0) end)
+ "Allocate a foreign string containing Lisp string STRING.
+The string must be freed with FOREIGN-STRING-FREE."
+ (check-type string string)
+ (cffi::with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
+ (start start) (end end))
+ (declare (type simple-string string))
+ (let* ((mapping (cffi::lookup-mapping cffi::*foreign-string-mappings* encoding))
+ (count (funcall (cffi::octet-counter mapping) string start end 0))
+ (length (if null-terminated-p
+ (+ count (cffi::null-terminator-len encoding))
+ count))
+ (ptr (funcall alloc-fn length)))
+ (funcall (cffi::encoder mapping) string start end ptr 0)
+ (when null-terminated-p
+ (dotimes (i (cffi::null-terminator-len encoding))
+ (setf (mem-ref ptr :char (+ count i)) 0)))
+ (values ptr length))))
+
(defclass msg ()
- ((raw :accessor msg-raw :initform nil)
- (shared :accessor msg-shared :initform 0 :initarg :shared)))
+ ((raw :accessor msg-raw :initform nil)))
(defmethod initialize-instance :after ((inst msg) &key size data)
(let ((obj (foreign-alloc 'msg)))
- (with-slots (raw shared) inst
- (setf raw obj)
- (tg:finalize inst (lambda ()
- (%msg-close raw)
- (foreign-free raw)))
- (when shared
- (setf (foreign-slot-value obj 'msg 'shared) (if shared 1 0)))
- (cond (size (%msg-init-size raw size))
- (data
- (multiple-value-bind (ptr len)
- (etypecase data
- (string (foreign-string-alloc data))
- (array (values (foreign-alloc :uchar :initial-contents data)
- (length data))))
- (msg-init-data raw ptr len (callback zmq-free))))
- (t (msg-init raw))))))
+ (tg:finalize inst (lambda ()
+ (%msg-close obj)
+ (foreign-free obj)))
+ (cond (size (%msg-init-size obj size))
+ (data
+ (etypecase data
+ (string (copy-lisp-string-octets
+ data (lambda (sz)
+ (%msg-init-size obj sz)
+ (%msg-data obj))))
+ (array (progn
+ (%msg-init-size obj (length data))
+ (let ((ptr (%msg-data obj))
+ (i -1))
+ (map nil (lambda (x)
+ (setf (mem-aref ptr :uchar (incf i)) x))
+ data))))))
+ (t (msg-init obj)))
+ (setf (msg-raw inst) obj)))
(defclass pollitem ()
((raw :accessor pollitem-raw :initform nil)