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                                 null-terminated-p (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            (length (if null-terminated-p
  30                        (+ count (cffi::null-terminator-len encoding))
  31                        count))
  32            (ptr (funcall alloc-fn length)))
  33       (funcall (cffi::encoder mapping) string start end ptr 0)
  34       (when null-terminated-p
  35         (dotimes (i (cffi::null-terminator-len encoding))
  36           (setf (mem-ref ptr :char (+ count i)) 0)))
  37       (values ptr length))))
  38
  39 (defclass msg ()
  40   ((raw         :accessor msg-raw :initform nil)))
  41
  42 (defmethod initialize-instance :after ((inst msg) &key size data null-terminated-p)
  43   (let ((obj (foreign-alloc 'msg)))
  44     (tg:finalize inst (lambda ()
  45                         (%msg-close obj)
  46                         (foreign-free obj)))
  47     (cond (size (%msg-init-size obj size))
  48           (data
  49            (etypecase data
  50              (string (copy-lisp-string-octets
  51                       data (lambda (sz)
  52                              (%msg-init-size obj sz)
  53                              (%msg-data obj))
  54                       :null-terminated-p null-terminated-p))
  55              ((simple-array (unsigned-byte 8))
  56               (let ((len (length data)))
  57                 (%msg-init-size obj len)
  58                 (with-pointer-to-vector-data (ptr data)
  59                   (memcpy (%msg-data obj) ptr len))))
  60              (array (progn
  61                       (%msg-init-size obj (length data))
  62                       (let ((ptr (%msg-data obj))
  63                             (i -1))
  64                         (map nil (lambda (x)
  65                                    (setf (mem-aref ptr :uchar (incf i)) x))
  66                              data))))))
  67           (t (msg-init obj)))
  68     (setf (msg-raw inst) obj)))
  69
  70 (defclass pollitem ()
  71   ((raw         :accessor pollitem-raw :initform nil)
  72    (socket      :accessor pollitem-socket :initform nil :initarg :socket)
  73    (fd          :accessor pollitem-fd :initform -1 :initarg :fd)
  74    (events      :accessor pollitem-events :initform 0 :initarg :events)
  75    (revents     :accessor pollitem-revents :initform 0)))
  76
  77 (defmethod initialize-instance :after ((inst pollitem) &key)
  78   (let ((obj (foreign-alloc 'pollitem)))
  79     (setf (pollitem-raw inst) obj)
  80     (tg:finalize inst (lambda () (foreign-free obj)))))
  81
  82 (defun bind (s address)
  83   (with-foreign-string (addr address)
  84     (%bind s addr)))
  85
  86 (defun connect (s address)
  87   (with-foreign-string (addr address)
  88     (%connect s addr)))
  89
  90 (defmacro with-context ((context io-threads) &body body)
  91   `(let ((,context (init ,io-threads)))
  92      (unwind-protect
  93           (progn ,@body)
  94        (term ,context))))
  95
  96 (defmacro with-socket ((socket context type) &body body)
  97   `(let ((,socket (socket ,context ,type)))
  98      (unwind-protect
  99           (progn ,@body)
 100        (close ,socket))))
 101
 102 (defun msg-data-as-is (msg)
 103   (%msg-data (msg-raw msg)))
 104
 105 (defun msg-data-as-string (msg)
 106   (let ((data (%msg-data (msg-raw msg)))
 107         (size (%msg-size (msg-raw msg))))
 108     (unless (zerop (pointer-address data))
 109       (foreign-string-to-lisp data :count size))))
 110
 111 (defun msg-data-as-array (msg)
 112   (let ((data (%msg-data (msg-raw msg))))
 113     (unless (zerop (pointer-address data))
 114       (let* ((len (msg-size msg))
 115              (arr (#+lispworks sys:in-static-area
 116                                #-lispworks cl:identity
 117                                (make-array len :element-type '(unsigned-byte 8)))))
 118         (declare (type (simple-array (unsigned-byte 8)) arr))
 119         (with-pointer-to-vector-data (ptr arr)
 120           (memcpy ptr data len))
 121         arr))))
 122
 123 (defun send (s msg &optional flags)
 124   (%send s (msg-raw msg) (or flags 0)))
 125
 126 (defun recv (s msg &optional flags)
 127   (%recv s (msg-raw msg) (or flags 0)))
 128
 129 (defun msg-init-size (msg size)
 130   (%msg-init-size (msg-raw msg) size))
 131
 132 (defun msg-close (msg)
 133   (%msg-close (msg-raw msg)))
 134
 135 (defun msg-size (msg)
 136   (%msg-size (msg-raw msg)))
 137
 138 (defun msg-move (dst src)
 139   (%msg-move (msg-raw dst) (msg-raw src)))
 140
 141 (defun msg-copy (dst src)
 142   (%msg-copy (msg-raw dst) (msg-raw src)))
 143
 144 (defun setsockopt (socket option value)
 145   (etypecase value
 146     (string (with-foreign-string (string value)
 147               (%setsockopt socket option string (length value))))
 148     (integer (with-foreign-object (int :int64)
 149                (setf (mem-aref int :int64) value)
 150                (%setsockopt socket option int (foreign-type-size :int64))))))
 151
 152 (defun getsockopt (socket option)
 153   (with-foreign-objects ((opt :int64)
 154                          (len :long))
 155     (setf (mem-aref opt :int64) 0
 156           (mem-aref len :long) (foreign-type-size :int64))
 157     (%getsockopt socket option opt len)
 158     (mem-aref opt :int64)))
 159
 160 (defun poll (items &optional (timeout -1))
 161   (let ((len (length items)))
 162     (with-foreign-object (%items 'pollitem len)
 163       (dotimes (i len)
 164         (let ((item (nth i items))
 165               (%item (mem-aref %items 'pollitem i)))
 166           (with-foreign-slots ((socket fd events revents) %item pollitem)
 167             (setf socket (pollitem-socket item)
 168                   fd (pollitem-fd item)
 169                   events (pollitem-events item)))))
 170       (let ((ret (%poll %items len timeout)))
 171         (cond
 172           ((zerop ret) nil)
 173           ((plusp ret)
 174            (loop for i below len
 175               for revent = (foreign-slot-value (mem-aref %items 'pollitem i)
 176                                                'pollitem
 177                                                'revents)
 178               collect (setf (pollitem-revents (nth i items)) revent)))
 179           (t (error (convert-from-foreign (%strerror (errno)) :string))))))))
 180
 181 (defmacro with-polls (list &body body)
 182   `(let ,(loop for (name . polls) in list
 183             collect `(,name
 184                       (list
 185                        ,@(loop for (socket . events) in polls
 186                             collect `(make-instance 'pollitem
 187                                                     :socket ,socket
 188                                                     :events ,events)))))
 189      ,@body))
 190
 191 (defun version ()
 192   (with-foreign-objects ((major :int)
 193                          (minor :int)
 194                          (patch :int))
 195     (%version major minor patch)
 196     (format nil "~d.~d.~d"
 197             (mem-ref major :int)
 198             (mem-ref minor :int)
 199             (mem-ref patch :int))))
 200
 201 (defun device (device insocket outsocket)
 202   (%device device insocket outsocket))