Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

207 lines (179 sloc) 7.64 kB
;; Copyright (c) 2009, 2010 Vitaly Mayatskikh <v.mayatskih@gmail.com>
;;
;; This file is part of CL-ZMQ.
;;
;; Vitaly Mayatskikh grants you the rights to distribute
;; and use this software as governed by the terms
;; of the Lisp Lesser GNU Public License
;; (http://opensource.franz.com/preamble.html),
;; known as the LLGPL.
(in-package :zeromq)
(defcfun ("memcpy" memcpy) :pointer
(dst :pointer)
(src :pointer)
(len :long))
;; 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*)
(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))
(ptr (funcall alloc-fn count)))
(funcall (cffi::encoder mapping) string start end ptr 0)
(values ptr count))))
(defclass msg ()
((raw :accessor msg-raw :initform nil)))
(defmethod initialize-instance :after ((inst msg) &key size data)
(let ((obj (foreign-alloc 'msg)))
(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))))
((simple-array (unsigned-byte 8))
(let ((len (length data)))
(%msg-init-size obj len)
(with-pointer-to-vector-data (ptr data)
(memcpy (%msg-data obj) ptr len))))
(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)
(socket :accessor pollitem-socket :initform (cffi:null-pointer) :initarg :socket)
(fd :accessor pollitem-fd :initform -1 :initarg :fd)
(events :accessor pollitem-events :initform 0 :initarg :events)
(revents :accessor pollitem-revents :initform 0)))
(defmethod initialize-instance :after ((inst pollitem) &key)
(let ((obj (foreign-alloc 'pollitem)))
(setf (pollitem-raw inst) obj)
(tg:finalize inst (lambda () (foreign-free obj)))))
(defun bind (s address)
(with-foreign-string (addr address)
(%bind s addr)))
(defun connect (s address)
(with-foreign-string (addr address)
(%connect s addr)))
(defmacro with-context ((context io-threads) &body body)
`(let ((,context (init ,io-threads)))
(unwind-protect
(progn ,@body)
(term ,context))))
(defmacro with-socket ((socket context type) &body body)
`(let ((,socket (socket ,context ,type)))
(unwind-protect
(progn ,@body)
(close ,socket))))
(defun msg-data-as-is (msg)
(%msg-data (msg-raw msg)))
(defun msg-data-as-string (msg)
(let ((data (%msg-data (msg-raw msg)))
(size (%msg-size (msg-raw msg))))
(unless (zerop (pointer-address data))
(foreign-string-to-lisp data :count size))))
(defun msg-data-as-array (msg)
(let ((data (%msg-data (msg-raw msg))))
(unless (zerop (pointer-address data))
(let* ((len (msg-size msg))
(arr (#+lispworks sys:in-static-area
#-lispworks cl:identity
(make-array len :element-type '(unsigned-byte 8)))))
(declare (type (simple-array (unsigned-byte 8)) arr))
(with-pointer-to-vector-data (ptr arr)
(memcpy ptr data len))
arr))))
(defun send (s msg &optional flags)
(%send s (msg-raw msg) (or flags 0)))
(defun recv (s msg &optional flags)
(%recv s (msg-raw msg) (or flags 0)))
(defun msg-init-size (msg size)
(%msg-init-size (msg-raw msg) size))
(defun msg-close (msg)
(%msg-close (msg-raw msg)))
(defun msg-size (msg)
(%msg-size (msg-raw msg)))
(defun msg-move (dst src)
(%msg-move (msg-raw dst) (msg-raw src)))
(defun msg-copy (dst src)
(%msg-copy (msg-raw dst) (msg-raw src)))
(defun setsockopt (socket option value)
(etypecase value
(string (with-foreign-string (string value)
(%setsockopt socket option string (length value))))
(integer (cond
((= option linger)
(with-foreign-object (int :int)
(setf (mem-aref int :int) value)
(%setsockopt socket option int (foreign-type-size :int))))
(t
(with-foreign-object (int :int64)
(setf (mem-aref int :int64) value)
(%setsockopt socket option int (foreign-type-size :int64))))))))
(defun getsockopt (socket option)
(with-foreign-objects ((opt :int64)
(len :long))
(setf (mem-aref opt :int64) 0
(mem-aref len :long) (foreign-type-size :int64))
(%getsockopt socket option opt len)
(mem-aref opt :int64)))
(defun poll (items &key (timeout -1) retry)
(let ((len (length items)))
(with-foreign-object (%items 'pollitem len)
(dotimes (i len)
(let ((item (nth i items))
(%item (mem-aref %items 'pollitem i)))
(with-foreign-slots ((socket fd events revents) %item pollitem)
(setf socket (pollitem-socket item)
fd (pollitem-fd item)
events (pollitem-events item)))))
(tagbody retry
(let ((ret (%poll %items len timeout)))
(cond
((zerop ret) nil)
((plusp ret)
(return-from poll
(loop for i below len
for revent = (foreign-slot-value (mem-aref %items 'pollitem i)
'pollitem
'revents)
collect (setf (pollitem-revents (nth i items)) revent))))
(t (let ((errno (errno)))
(if (and retry (= errno iolib.syscalls:eintr))
(go retry)
(error (convert-from-foreign (%strerror errno) :string)))))))))))
(defmacro with-polls (list &body body)
`(let ,(loop for (name . polls) in list
collect `(,name
(list
,@(loop for (socket . events) in polls
collect `(make-instance 'pollitem
:socket ,socket
:events ,events)))))
,@body))
(defun version ()
(with-foreign-objects ((major :int)
(minor :int)
(patch :int))
(%version major minor patch)
(format nil "~d.~d.~d"
(mem-ref major :int)
(mem-ref minor :int)
(mem-ref patch :int))))
(defun device (device insocket outsocket)
(%device device insocket outsocket))
Jump to Line
Something went wrong with that request. Please try again.