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