zeromq-api.lisp

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