Under the MIT/X11 license.
--
--ska
From 350d1e6c174aad17d84717fc8a024632807a2339 Mon Sep 17 00:00:00 2001
From: Kamil Shakirov <kamil...@gmail.com>
Date: Mon, 18 Oct 2010 20:27:03 +0700
Subject: [PATCH] Add zmsg.lisp and zmsg_test.lisp examples.
---
examples/Common Lisp/.gitignore | 1 +
examples/Common Lisp/zmsg.asd | 22 +++
examples/Common Lisp/zmsg.lisp | 278 +++++++++++++++++++++++++++++++++--
examples/Common Lisp/zmsg_test.asd | 21 +++
examples/Common Lisp/zmsg_test.lisp | 24 ++--
5 files changed, 326 insertions(+), 20 deletions(-)
create mode 100644 examples/Common Lisp/zmsg.asd
create mode 100644 examples/Common Lisp/zmsg_test.asd
diff --git a/examples/Common Lisp/.gitignore b/examples/Common Lisp/.gitignore
index 9f457eb..2b4e173 100644
--- a/examples/Common Lisp/.gitignore
+++ b/examples/Common Lisp/.gitignore
@@ -1,5 +1,6 @@
# ignore file
+/zmsg_test
/rtrouter
/lruqueue
/rtpapa
diff --git a/examples/Common Lisp/zmsg.asd b/examples/Common Lisp/zmsg.asd
new file mode 100644
index 0000000..81dc526
--- /dev/null
+++ b/examples/Common Lisp/zmsg.asd
@@ -0,0 +1,22 @@
+;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
+;;;
+;;; Multipart message class for example applications in Common Lisp
+;;;
+;;; Kamil Shakirov <kamil...@gmail.com>
+;;;
+
+(defpackage #:zguide.zmsg.asd
+ (:use #:cl #:asdf))
+
+(in-package :zguide.zmsg.asd)
+
+(defsystem zmsg
+ :version "0.0.0"
+ :description "Multipart message class for example applications in Common Lisp."
+ :maintainer "Kamil Shakirov <kamil...@gmail.com>"
+ :author "Kamil Shakirov <kamil...@gmail.com>"
+ :licence "MIT/X11"
+ :depends-on (:zeromq)
+ :serial t
+ :components ((:file "zhelpers")
+ (:file "zmsg" :depends-on ("zhelpers"))))
diff --git a/examples/Common Lisp/zmsg.lisp b/examples/Common Lisp/zmsg.lisp
index 0758dfa..ddd0a44 100644
--- a/examples/Common Lisp/zmsg.lisp
+++ b/examples/Common Lisp/zmsg.lisp
@@ -1,13 +1,271 @@
-No-one has translated the zmsg example into Common Lisp yet. Be the first to create
-zmsg in Common Lisp and get one free Internet! If you're the author of the Common Lisp
-binding, this is a great way to get people to use 0MQ in Common Lisp.
+;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
+;;;
+;;; Multipart message class for example applications in Common Lisp
+;;;
+;;; Kamil Shakirov <kamil...@gmail.com>
+;;;
-To submit a new translation email it to zeromq-...@lists.zeromq.org. Please:
+(defpackage #:zguide.zmsg
+ (:nicknames #:zmsg)
+ (:use #:cl)
+ (:shadow #:recv #:send #:push #:pop)
+ (:export
+ #:message
+ #:make-message
+ #:recv
+ #:send
+ #:parts
+ #:body
+ #:set-body
+ #:format-body
+ #:push
+ #:pop
+ #:address
+ #:wrap
+ #:unwrap
+ #:dump
+ #:test))
-* Stick to identical functionality and naming used in examples so that readers
- can easily compare languages.
-* You MUST place your name as author in the examples so readers can contact you.
-* You MUST state in the email that you license your code under the MIT/X11
- license.
+(in-package :zguide.zmsg)
-Subscribe to this list at http://lists.zeromq.org/mailman/listinfo/zeromq-dev.
+(defparameter +hex-char+ "0123456789ABCDEF")
+
+(defparameter +hex-to-bin+
+ #(-1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
+ -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
+ -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
+ 0 1 2 3 4 5 6 7 8 9 -1 -1 -1 -1 -1 -1
+ -1 10 11 12 13 14 15 -1 -1 -1 -1 -1 -1 -1 -1 -1
+ -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1
+ -1 10 11 12 13 14 15 -1 -1 -1 -1 -1 -1 -1 -1 -1
+ -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1 -1))
+
+(defun uuid-encode (data)
+ "Formats 17-byte UUID as 33-char string starting with '@'."
+ (assert (and (= (array-rank data) 1)
+ (= (array-total-size data) 17)
+ (= 0 (aref data 0))))
+ (let ((uuid (make-array 32 :element-type 'character)))
+ (dotimes (i 16)
+ (setf (char uuid (* i 2)) (char +hex-char+ (ash (aref data (1+ i)) -4)))
+ (setf (char uuid (1+ (* i 2))) (char +hex-char+ (logand (aref data (1+ i)) 15))))
+ (format nil "@~A" uuid)))
+
+(defun uuid-decode (uuid)
+ "Decodes 33-char string starting with '@' to 17-byte UUID."
+ (assert (and (= 33 (length uuid))
+ (char= #\@ (char uuid 0))))
+ (let ((data (make-array 17 :element-type '(unsigned-byte 8))))
+ (setf (aref data 0) 0)
+ (dotimes (i 16)
+ (setf (aref data (1+ i))
+ (+ (ash
+ (aref +hex-to-bin+
+ (logand (char-code
+ (char uuid (1+ (* 2 i))))
+ 127))
+ 4)
+ (aref +hex-to-bin+
+ (logand (char-code
+ (char uuid (+ (* 2 i) 2)))
+ 127)))))
+ data))
+
+;; * We don't care about zero-copy performance, so messages hold copies of data.
+;; * Receiving a message always calls the constructor so we don't need extra constructors.
+;; * Sending a message always calls the destructor, and sets the message reference to null.
+;; * Message parts (addresses and data) are always printable strings.
+
+(defstruct (message
+ (:constructor %make-message)
+ (:copier nil))
+ (parts nil :type (or null list))
+ (parts-count 0 :type fixnum))
+
+(defun make-message ()
+ "Creates empty message."
+ (%make-message))
+
+(defun recv (socket)
+ "Receives message from socket.
+
+Creates a new message and returns it. Blocks on recv if socket is not ready
+for input."
+ (loop :with parts = (list)
+ :for parts-count :from 1
+ :do (let ((msg (make-instance 'zmq:msg)))
+ (zmq:recv socket msg)
+ ;; We handle 0MQ UUIDs as printable strings
+ (let ((data (zmq:msg-data-as-array msg)))
+ (if (and (= 17 (zmq:msg-size msg))
+ (= (aref data 0) 0))
+ ;; Store message part as string uuid
+ (let ((uuid (uuid-encode data)))
+ (cl:push (cons (length uuid) uuid) parts))
+ ;; Store this message part
+ (cl:push (cons (zmq:msg-size msg) (zmq:msg-data-as-string msg)) parts))))
+ :until (zerop (zmq:getsockopt socket zmq:rcvmore)) ; last message part
+ :finally (return (%make-message :parts (nreverse parts) :parts-count parts-count))))
+
+(defun send (message socket)
+ "Sends message to socket."
+ ;; Unmangle 0MQ identities for writing to the socket
+ (loop :for (size . text) :in (message-parts message)
+ :for msg = (if (and (= 33 size)
+ (char= #\@ (char text 0)))
+ (make-instance 'zmq:msg :data (uuid-decode text) :size size)
+ (make-instance 'zmq:msg :data text))
+ :do (if (zerop (decf (message-parts-count message)))
+ (zmq:send socket msg)
+ (zmq:send socket msg zmq:sndmore))))
+
+(defun parts (message)
+ "Reports size of message."
+ (message-parts-count message))
+
+(defun body (message)
+ "Returns message body, if any.
+
+Caller should not modify the provided data."
+ (and (message-parts message)
+ (cdr (nth (1- (message-parts-count message)) (message-parts message)))))
+
+(defun set-body (message body)
+ "Sets message body as copy of provided string.
+
+If message is empty, creates a new message body."
+ (let ((part (cons (length body) body)))
+ (if (null (message-parts message))
+ (progn
+ (cl:push part (message-parts message))
+ (incf (message-parts-count message)))
+ (setf (nth (1- (message-parts-count message)) (message-parts message)) part)))
+ (values))
+
+(defun format-body (message fmt &rest args)
+ "Sets message body using format.
+
+If message is empty, creates a new message body."
+ (set-body message (apply #'format nil fmt args)))
+
+(defun push (message part)
+ "Pushes message part to front of message parts."
+ (incf (message-parts-count message))
+ (cl:push (cons (length part) part) (message-parts message))
+ (values))
+
+(defun pop (message)
+ "Pops message part off front of message parts."
+ (decf (message-parts-count message))
+ (cdr (cl:pop (message-parts message))))
+
+(defun address (message)
+ "Returns pointer to outer message address, if any.
+
+Caller should not modify the provided data."
+ (cdr (car (message-parts message))))
+
+(defun wrap (message address &optional delim)
+ "Wraps message in new address envelope.
+
+If delim is not NIL, creates two-part envelope."
+ (when delim
+ ;; Push optional delimiter and then address
+ (push message delim))
+ (push message address))
+
+(defun unwrap (message)
+ "Unwraps outer message envelope and returns address.
+
+Discards empty message part after address, if any."
+ (prog1 (pop message)
+ (when (zerop (length (address message)))
+ (pop message))))
+
+(defun text-part-p (part)
+ (loop :for char :across part
+ :for code = (char-code char)
+ :never (or (> 32 code) (< 127 code))))
+
+(defun dump (message)
+ "Dumps message for debugging and tracing."
+ ;; Dump the message as text or binary
+ (let ((*standard-output* *error-output*))
+ (loop :for (size . data) in (message-parts message)
+ :do (format t "[~3,'0D] " size)
+ (if (text-part-p data)
+ (write-string data)
+ (loop :for x :across data
+ :do (format t "~2,'0X" (char-code x))))
+ (terpri))
+ (finish-output)))
+
+(defun test (&optional verbosep)
+ "Runs self test of class."
+ (format t " * zmsg: ")
+
+ ;; Prepare our context and sockets
+ (zmq:with-context (context 1)
+ (zmq:with-socket (output context zmq:xreq)
+ (zmq:bind output "ipc://zmsg_selftest.ipc")
+
+ (zmq:with-socket (input context zmq:xrep)
+ (zmq:connect input "ipc://zmsg_selftest.ipc")
+
+ ;; Test send and receive of single-part message
+ (let ((message (make-message)))
+ (set-body message "Hello")
+ (assert (string= (body message) "Hello"))
+ (send message output)
+
+ (let ((message (recv input)))
+ (assert (= (parts message) 2))
+ (when verbosep
+ (dump message))
+ (assert (string= (body message) "Hello"))))
+
+ ;; Test send and receive of multi-part message
+ (let ((message (make-message)))
+ (set-body message "Hello")
+ (wrap message "address1" "")
+ (wrap message "address2")
+ (assert (= (parts message) 4))
+ (send message output)
+
+ (let ((message (recv input)))
+ (when verbosep
+ (dump message))
+ (assert (= (parts message) 5))
+ (assert (= 33 (length (address message))))
+ (unwrap message)
+ (assert (string= (address message) "address2"))
+ (format-body message "~C~A" #\W "orld")
+ (send message output))
+
+ (let ((message (recv input)))
+ (unwrap message)
+ (assert (= (parts message) 4))
+ (string= (body message) "World")
+ (let ((part (unwrap message)))
+ (assert (string= part "address2")))
+
+ ;; Pull off address 1, check that empty part was dropped
+ (let ((part (unwrap message)))
+ (assert (string= part "address1"))
+ (assert (= 1 (parts message))))
+
+ ;; Check that message body was correctly modified
+ (let ((part (pop message)))
+ (assert (string= part "World"))
+ (assert (zerop (parts message)))))
+
+ (format t "OK~%"))))))
+
+;; [033] @02E39A16025D42E68BEA84F25D6A9A0A
+;; [005] Hello
+;; [033] @02E39A16025D42E68BEA84F25D6A9A0A
+;; [008] address2
+;; [008] address1
+;; [000]
+;; [005] Hello
+;; * zmsg: OK
diff --git a/examples/Common Lisp/zmsg_test.asd b/examples/Common Lisp/zmsg_test.asd
new file mode 100644
index 0000000..13778b3
--- /dev/null
+++ b/examples/Common Lisp/zmsg_test.asd
@@ -0,0 +1,21 @@
+;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
+;;;
+;;; Test zmsg class in Common Lisp
+;;;
+;;; Kamil Shakirov <kamil...@gmail.com>
+;;;
+
+(defpackage #:zguide.zmsg_test.asd
+ (:use #:cl #:asdf))
+
+(in-package :zguide.zmsg_test.asd)
+
+(defsystem zmsg_test
+ :version "0.0.0"
+ :description "Test zmsg class in Common Lisp."
+ :maintainer "Kamil Shakirov <kamil...@gmail.com>"
+ :author "Kamil Shakirov <kamil...@gmail.com>"
+ :licence "MIT/X11"
+ :depends-on (:zmsg)
+ :serial t
+ :components ((:file "zmsg_test")))
diff --git a/examples/Common Lisp/zmsg_test.lisp b/examples/Common Lisp/zmsg_test.lisp
index 3484871..430f8b7 100644
--- a/examples/Common Lisp/zmsg_test.lisp
+++ b/examples/Common Lisp/zmsg_test.lisp
@@ -1,13 +1,17 @@
-No-one has translated the zmsg_test example into Common Lisp yet. Be the first to create
-zmsg_test in Common Lisp and get one free Internet! If you're the author of the Common Lisp
-binding, this is a great way to get people to use 0MQ in Common Lisp.
+;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; -*-
+;;;
+;;; Test zmsg class in Common Lisp
+;;;
+;;; Kamil Shakirov <kamil...@gmail.com>
+;;;
-To submit a new translation email it to zeromq-...@lists.zeromq.org. Please:
+(defpackage #:zguide.zmsg_test
+ (:nicknames #:zmsg_test)
+ (:use #:cl #:zhelpers)
+ (:export #:main))
-* Stick to identical functionality and naming used in examples so that readers
- can easily compare languages.
-* You MUST place your name as author in the examples so readers can contact you.
-* You MUST state in the email that you license your code under the MIT/X11
- license.
+(in-package :zguide.zmsg_test)
-Subscribe to this list at http://lists.zeromq.org/mailman/listinfo/zeromq-dev.
+(defun main ()
+ (zmsg:test t)
+ (cleanup))
--
1.7.0.4
_______________________________________________
zeromq-dev mailing list
zeromq-dev@lists.zeromq.org
http://lists.zeromq.org/mailman/listinfo/zeromq-dev
