zeromq-api.lisp

   1 ;; Copyright (c) 2009, 2010 Vitaly Mayatskikh <v.mayatskih@gmail.com>
   2 ;;
   3 ;; This file is part of CL-ZMQ.
   4 ;;
   5 ;; Vitaly Mayatskikh grants you the rights to distribute
   6 ;; and use this software as governed by the terms
   7 ;; of the Lisp Lesser GNU Public License
   8 ;; (http://opensource.franz.com/preamble.html),
   9 ;; known as the LLGPL.
  10
  11 (in-package :zeromq)
  12
  13 (defcfun ("memcpy" memcpy) :pointer
  14   (dst  :pointer)
  15   (src  :pointer)
  16   (len  :long))
  17
  18 ;; Stolen from CFFI. Uses custom allocator (alloc-fn) instead of foreign-alloc
  19 (defun copy-lisp-string-octets (string alloc-fn &key (encoding cffi::*default-foreign-encoding*)
  20                                 (start 0) end)
  21   "Allocate a foreign string containing Lisp string STRING.
  22 The string must be freed with FOREIGN-STRING-FREE."
  23   (check-type string string)
  24   (cffi::with-checked-simple-vector ((string (coerce string 'babel:unicode-string))
  25                                      (start start) (end end))
  26     (declare (type simple-string string))
  27     (let* ((mapping (cffi::lookup-mapping cffi::*foreign-string-mappings* encoding))
  28            (count (funcall (cffi::octet-counter mapping) string start end 0))
  29            (ptr (funcall alloc-fn count)))
  30       (funcall (cffi::encoder mapping) string start end ptr 0)
  31       (values ptr count))))
  32
  33 (defclass msg ()
  34   ((raw         :accessor msg-raw :initform nil)))
  35
  36 (defmethod initialize-instance :after ((inst msg) &key size data)
  37   (let ((obj (foreign-alloc 'msg)))
  38     (tg:finalize inst (lambda ()
  39                         (%msg-close obj)
  40                         (foreign-free obj)))
  41     (cond (size (%msg-init-size obj size))
  42           (data
  43            (etypecase data
  44              (string (copy-lisp-string-octets
  45                       data (lambda (sz)
  46                              (%msg-init-size obj sz)
  47                              (%msg-data obj))))
  48              ((simple-array (unsigned-byte 8))
  49               (let ((len (length data)))
  50                 (%msg-init-size obj len)
  51                 (with-pointer-to-vector-data (ptr data)
  52                   (memcpy (%msg-data obj) ptr len))))
  53              (array (progn
  54                       (%msg-init-size obj (length data))
  55                       (let ((ptr (%msg-data obj))
  56                             (i -1))
  57                         (map nil (lambda (x)
  58                                    (setf (mem-aref ptr :uchar (incf i)) x))
  59                              data))))))
  60           (t (msg-init obj)))
  61     (setf (msg-raw inst) obj)))
  62
  63 (defclass pollitem ()
  64   ((raw         :accessor pollitem-raw :initform nil)
  65    (socket      :accessor pollitem-socket :initform nil :initarg :socket)
  66    (fd          :accessor pollitem-fd :initform -1 :initarg :fd)
  67    (events      :accessor pollitem-events :initform 0 :initarg :events)
  68    (revents     :accessor pollitem-revents :initform 0)))
  69
  70 (defmethod initialize-instance :after ((inst pollitem) &key)
  71   (let ((obj (foreign-alloc 'pollitem)))
  72     (setf (pollitem-raw inst) obj)
  73     (tg:finalize inst (lambda () (foreign-free obj)))))
  74
  75 (defun bind (s address)
  76   (with-foreign-string (addr address)
  77     (%bind s addr)))
  78
  79 (defun connect (s address)
  80   (with-foreign-string (addr address)
  81     (%connect s addr)))
  82
  83 (defmacro with-context ((context io-threads) &body body)
  84   `(let ((,context (init ,io-threads)))
  85      (unwind-protect
  86           (progn ,@body)
  87        (term ,context))))
  88
  89 (defmacro with-socket ((socket context type) &body body)
  90   `(let ((,socket (socket ,context ,type)))
  91      (unwind-protect
  92           (progn ,@body)
  93        (close ,socket))))
  94
  95 (defun msg-data-as-is (msg)
  96   (%msg-data (msg-raw msg)))
  97
  98 (defun msg-data-as-string (msg)
  99   (let ((data (%msg-data (msg-raw msg)))
 100         (size (%msg-size (msg-raw msg))))
 101     (unless (zerop (pointer-address data))
 102       (foreign-string-to-lisp data :count size))))
 103
 104 (defun msg-data-as-array (msg)
 105   (let ((data (%msg-data (msg-raw msg))))
 106     (unless (zerop (pointer-address data))
 107       (let* ((len (msg-size msg))
 108              (arr (#+lispworks sys:in-static-area
 109                                #-lispworks cl:identity
 110                                (make-array len :element-type '(unsigned-byte 8)))))
 111         (declare (type (simple-array (unsigned-byte 8)) arr))
 112         (with-pointer-to-vector-data (ptr arr)
 113           (memcpy ptr data len))
 114         arr))))
 115
 116 (defun send (s msg &optional flags)
 117   (%send s (msg-raw msg) (or flags 0)))
 118
 119 (defun recv (s msg &optional flags)
 120   (%recv s (msg-raw msg) (or flags 0)))
 121
 122 (defun msg-init-size (msg size)
 123   (%msg-init-size (msg-raw msg) size))
 124
 125 (defun msg-close (msg)
 126   (%msg-close (msg-raw msg)))
 127
 128 (defun msg-size (msg)
 129   (%msg-size (msg-raw msg)))
 130
 131 (defun msg-move (dst src)
 132   (%msg-move (msg-raw dst) (msg-raw src)))
 133
 134 (defun msg-copy (dst src)
 135   (%msg-copy (msg-raw dst) (msg-raw src)))
 136
 137 (defun setsockopt (socket option value)
 138   (etypecase value
 139     (string (with-foreign-string (string value)
 140               (%setsockopt socket option string (length value))))
 141     (integer (with-foreign-object (int :int64)
 142                (setf (mem-aref int :int64) value)
 143                (%setsockopt socket option int (foreign-type-size :int64))))))
 144
 145 (defun getsockopt (socket option)
 146   (with-foreign-objects ((opt :int64)
 147                          (len :long))
 148     (setf (mem-aref opt :int64) 0
 149           (mem-aref len :long) (foreign-type-size :int64))
 150     (%getsockopt socket option opt len)
 151     (mem-aref opt :int64)))
 152
 153 (defun poll (items &optional (timeout -1))
 154   (let ((len (length items)))
 155     (with-foreign-object (%items 'pollitem len)
 156       (dotimes (i len)
 157         (let ((item (nth i items))
 158               (%item (mem-aref %items 'pollitem i)))
 159           (with-foreign-slots ((socket fd events revents) %item pollitem)
 160             (setf socket (pollitem-socket item)
 161                   fd (pollitem-fd item)
 162                   events (pollitem-events item)))))
 163       (let ((ret (%poll %items len timeout)))
 164         (cond
 165           ((zerop ret) nil)
 166           ((plusp ret)
 167            (loop for i below len
 168               for revent = (foreign-slot-value (mem-aref %items 'pollitem i)
 169                                                'pollitem
 170                                                'revents)
 171               collect (setf (pollitem-revents (nth i items)) revent)))
 172           (t (error (convert-from-foreign (%strerror (errno)) :string))))))))
 173
 174 (defmacro with-polls (list &body body)
 175   `(let ,(loop for (name . polls) in list
 176             collect `(,name
 177                       (list
 178                        ,@(loop for (socket . events) in polls
 179                             collect `(make-instance 'pollitem
 180                                                     :socket ,socket
 181                                                     :events ,events)))))
 182      ,@body))
 183
 184 (defun version ()
 185   (with-foreign-objects ((major :int)
 186                          (minor :int)
 187                          (patch :int))
 188     (%version major minor patch)
 189     (format nil "~d.~d.~d"
 190             (mem-ref major :int)
 191             (mem-ref minor :int)
 192             (mem-ref patch :int))))
 193
 194 (defun device (device insocket outsocket)
 195   (%device device insocket outsocket))