POSIX message queues for Common Lisp.

mqueue.asd

;; This is free and unencumbered software released into the public domain.

(asdf:defsystem :mqueue
  :name "mqueue"
  :description "POSIX message queues for Common Lisp."
  :version "0.0.0"
  :author "Arto Bendiken <arto@datagraph.org>"
  :depends-on (:cffi)
  :serial t
  :components ((:file "mqueue")))

mqueue.lisp

;; This is free and unencumbered software released into the public domain.

(defpackage :mqueue
  (:use :cl :cffi :cffi-sys #+sbcl :sb-alien)
  (:export :load-library
           :unload-library
           :unlink-queue
           :open-queue
           :close-queue
           :send-message
           :receive-message)
  (:shadow :error))

(in-package :mqueue)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-foreign-library librt
    (:unix (:or "librt.so.0" "librt.so"))
    (:darwin (:or "librt.0.dylib" "librt.dylib"))
    (t (:default "librt"))))

;; #include <fcntl.h>
(defparameter +O_RDONLY+ 00000000) ;; Linux: /usr/include/asm-generic/fcntl.h
(defparameter +O_WRONLY+ 00000001) ;; Linux: /usr/include/asm-generic/fcntl.h
(defparameter +O_RDWR+   00000002) ;; Linux: /usr/include/asm-generic/fcntl.h
(defparameter +O_CREAT+  00000100) ;; Linux: /usr/include/asm-generic/fcntl.h

(defmacro errno ()
  `(sb-alien:get-errno))

(defcfun ("strerror" %%strerror) :string (errnum :int))

(defctype descriptor :int) ;; NOTE: platform-specific type

(define-condition error (cl:error) ())

(define-condition foreign-function-error (error)
  ((function :initarg :function :reader foreign-function-error-function)
   (code :initarg :code :reader foreign-function-error-code)
   (message :initarg :message :reader foreign-function-error-message))
  (:report (lambda (condition stream)
             (format stream "~A failed with error code ~A: ~A"
                     (foreign-function-error-function condition)
                     (foreign-function-error-code condition)
                     (foreign-function-error-message condition)))))

(define-condition unknown-pathname (foreign-function-error) ())    ;; ENOENT (2)
(define-condition bad-file-descriptor (foreign-function-error) ()) ;; EBADF  (9)
(define-condition disallowed-access (foreign-function-error) ())   ;; EACCES (13)

(defun foreign-function-error (errno function-name &optional message)
  (declare (type fixnum errno)
           (type string function-name))
  (cl:error (find-foreign-function-error-class errno)
            :function function-name
            :code errno
            :message (or message (%%strerror errno))))

(defun find-foreign-function-error-class (errno)
  (declare (type fixnum errno))
  (case errno
    (2  'unknown-pathname)
    (9  'bad-file-descriptor)
    (13 'disallowed-access)
    (t  'foreign-function-error)))

(defmacro with-checked-ssize-result (cfun-name &rest body)
  (let ((ssize-var (gensym))
        (errno-var (gensym)))
    `(let ((,ssize-var (progn ,@body)))
       (declare (type integer ,ssize-var))
       (if (>= ,ssize-var 0)
           ,ssize-var
           (foreign-function-error (errno) ,cfun-name)))))

(defmacro with-checked-int-result (cfun-name &rest body)
  `(with-checked-ssize-result ,cfun-name ,@body))

(defun load-library (&key path version debug features)
  "Loads the POSIX message queue library.
   Must be called before invoking any foreign functions in the library."
  (declare (type boolean debug)
           (type list features))
  (load-foreign-library 'librt)
  (values)) ;;; no meaningful return value

(defun unload-library ()
  "Unloads the POSIX message queue library."
  (close-foreign-library 'librt)
  (values)) ;;; no meaningful return value

;; int mq_unlink(const char* name)
(defcfun ("mq_unlink" %%unlink) :int (name :string))

(defun unlink-queue (queue-name)
  "Removes a message queue from the system."
  (declare (type string queue-name))
  (with-checked-int-result "mq_unlink"
    (%%unlink queue-name))
  (values)) ;;; no meaningful return value

;; mqd_t mq_open(const char* name, int oflag, mode_t mode, struct mq_attr* attr)
(defcfun ("mq_open" %%open) descriptor (name :string) (oflag :int) (mode :int) (attr :pointer))

(defun open-queue (queue-name &key direction)
  "Opens or creates a message queue."
  (declare (type string queue-name)
           (type (or keyword null) direction))
  (let ((flags +O_CREAT+)
        (mode #o666)) ;; FIXME
    (with-checked-int-result "mq_open"
      (%%open queue-name
              (ecase (or direction :input)
                (:input  (logior flags +O_RDONLY+))
                (:output (logior flags +O_WRONLY+))
                (:io     (logior flags +O_RDWR+)))
              mode
              (cffi:null-pointer)))))

;; int mq_close(mqd_t mqdes)
(defcfun ("mq_close" %%close) :int (mqdes descriptor))

(defun close-queue (queue-descriptor)
  "Closes a message queue descriptor."
  (declare (type fixnum queue-descriptor))
  (with-checked-int-result "mq_close"
    (%%close queue-descriptor))
  (values)) ;;; no meaningful return value

;; int mq_send(mqd_t mqdes, const char* msg_ptr, size_t msg_len, unsigned msg_prio)
(defcfun ("mq_send" %%send) :int (mqdes descriptor) (msg-ptr :pointer) (msg-len :ulong) (msg-prio :uint))

(defun send-message (queue-descriptor message-pointer message-size &key message-priority)
  "Sends a message to a message queue."
  (declare (type fixnum queue-descriptor message-size)
           (type foreign-pointer message-pointer)
           (type (or fixnum null) message-priority))
  (with-checked-int-result "mq_send"
    (%%send queue-descriptor message-pointer message-size
            (or message-priority 0)))
  (values)) ;;; no meaningful return value

;; ssize_t mq_receive(mqd_t mqdes, char* msg_ptr, size_t msg_len, unsigned* msg_prio)
(defcfun ("mq_receive" %%receive) :long (mqdes descriptor) (msg-ptr :pointer) (msg-len :ulong) (msg-prio :pointer))

(defun receive-message (queue-descriptor message-pointer message-size)
  "Receives a message from a message queue.
   Returns the number of bytes in the received message."
  (declare (type fixnum queue-descriptor message-size)
           (type foreign-pointer message-pointer))
  (with-checked-ssize-result "mq_receive"
    (%%receive queue-descriptor message-pointer message-size
               (cffi:null-pointer))))