From f8cc808c44d73993c6a66558fdfeef627091cd5a Mon Sep 17 00:00:00 2001 From: nik gaffney Date: Mon, 14 Mar 2005 22:05:05 +0800 Subject: [PATCH] podoscaph #bundle support added to the feet. small step towards watertightness darcs-hash:20050314140505-2648a-268ae71e964c269e196c590d867970411d786804.gz --- README.txt | 62 +++++++++++-- osc-dispatch.lisp | 2 +- osc-examples.lisp | 18 ++-- osc.lisp | 229 +++++++++++++++++++++++++++++----------------- 4 files changed, 209 insertions(+), 102 deletions(-) diff --git a/README.txt b/README.txt index 28df0a8..664f3b7 100644 --- a/README.txt +++ b/README.txt @@ -1,12 +1,60 @@ -what -> -This is a common-lisp implementation of the Open Sound Control Protocol, aka OSC. It should be close to ansi standard, and does not rely on any external code/ffi/etc+ to do the basic encoding and decoding of packets. since OSC does not specify a transport layer, messages can be send using TCP or UDP, however it seems UDP is more common amongst the programms that communicate using the protocol. -else -> - - specific info about what is/isnt working can be found in the header of osc.lisp - - more details about OSC can be found at - http://www.cnmat.berkeley.edu/OpenSoundControl/ - - current versions of this code can be found at http://fo.am/darcs/osc +This is a common-lisp implementation of the Open Sound Control +Protocol, aka OSC. The code should be close to ansi standard, and does +not rely on any external code/ffi/etc+ to do the basic encoding and +decoding of packets. since OSC does not specify a transport layer, +messages can be send using TCP or UDP (or carrier pigeons), however it +seems UDP is more common amongst the programmes that communicate using +the OSC protocol. the osc-examples.lisp file contains a few simple +examples of how to send and recieve OSC via UDP, and so far seems +reasonably compatible with the packets send from/to max-msp, pd, +supercollider and liblo. . . + +more details about OSC can be found at . ., + http://www.cnmat.berkeley.edu/OpenSoundControl/ + +the current version of this code is avilable using darcs + darcs get http://fo.am/darcs/osc + + +limitations + - doesnt send nested bundles or timetags later than 'now' + - will most likely crash if the input is malformed + - doesnt do any pattern matching on addresses + - sbcl/cmucl specific float en/decoding + - only supports the type(tag)s specified in the OSC spec + +things to do + - address patterns + - liblo like network wrapping + - data checking and error handling + - portable en/decoding of floats -=> ieee754 tests + - doubles and other defacto typetags + - correct en/decoding of timetags + - asdf-installable + + +changes + + 2005-03-11 + - bundle and blob en/de- coding + 2005-03-05 + - 'declare' scattering and other optimisations + 2005-02-08 + - in-package'd + - basic dispatcher + 2005-03-01 + - fixed address string bug + 2005-01-26 + - fixed string handling bug + 2005-01-24 + - sends and receives multiple arguments + - tests in osc-tests.lisp + 2004-12-18 + - initial version, single args only + + diff --git a/osc-dispatch.lisp b/osc-dispatch.lisp index 862545e..8fa3bf4 100644 --- a/osc-dispatch.lisp +++ b/osc-dispatch.lisp @@ -33,7 +33,7 @@ (in-package :osc) -;; should probably be a clos object, and instantiated +;; should probably be a clos object or an alist. ;; for now, a hash table is enuf. (defun make-osc-tree () diff --git a/osc-examples.lisp b/osc-examples.lisp index 07b550f..8983ad1 100644 --- a/osc-examples.lisp +++ b/osc-examples.lisp @@ -29,19 +29,19 @@ (require :sb-bsd-sockets) (use-package :osc) +(use-package :sb-bsd-sockets) + (defun osc-listen (port) - "a basic test function which attempts to decode osc stuff a - given port. default ogreOSC port is 4178" - + "a basic test function which attempts to decode an osc message a given port." (let ((s (make-udp-socket)) (buffer (make-sequence '(vector (unsigned-byte 8)) 1024))) (socket-bind s #(0 0 0 0) port) (format t "listening on localhost port ~A~%~%" port) (unwind-protect (loop do - (socket-receive s buffer nil :waitall t) - (format t "receiveded -=> ~S~%" (osc:decode-message buffer))) + (socket-receive s buffer nil) + (format t "receiveded -=> ~S~%" (osc:decode-bundle buffer))) (when s (socket-close s))))) @@ -59,10 +59,10 @@ :element-type '(unsigned-byte 8) :buffering :full))) (unwind-protect (loop do - (socket-receive in buffer nil :waitall t) - (let ((oscuff (osc:decode-message buffer))) + (socket-receive in buffer nil) + (let ((oscuff (osc:decode-bundle buffer))) (format t "glonked -=> message with ~S~% arg(s)" (length oscuff)) - (stream-t1 oscuff stream))) + (write-stream-t1 oscuff stream))) (when in (socket-close in)) (when out (socket-close out)))))) @@ -70,7 +70,7 @@ (defun make-udp-socket() (make-instance 'inet-socket :type :datagram :protocol :udp)) -(defun stream-t1 (osc-message stream) +(defun write-stream-t1 (osc-message stream) "writes a given message to a stream. keep in mind that when using a buffered stream any funtion writing to the stream should call (finish-output stream) after it sends the mesages,. ." diff --git a/osc.lisp b/osc.lisp index 2b6fe7e..9b7f897 100644 --- a/osc.lisp +++ b/osc.lisp @@ -10,7 +10,7 @@ ;; Where these conflict, the preamble takes precedence. The LLGPL ;; is available online at http://opensource.franz.com/preamble.html ;; and is distributed with this code (see: LICENCE and LGPL files) -;; +;; ;; authors ;; ;; nik gaffney @@ -27,48 +27,27 @@ ;; of the protocol can be found at the open sound control pages -=> ;; http://www.cnmat.berkeley.edu/OpenSoundControl/ ;; -;; - currently doesnt send timetags, but does send typetags -;; - will most likely crash if the input is malformed -;; - int32 en/de-coding based on code (c) Walter C. Pelissero - -;; to do +;; - doesnt send nested bundles or timetags later than 'now' +;; - will most likely crash if the input is malformed +;; - int32 en/de-coding based on code (c) Walter C. Pelissero +;; +;; see the README file for more details... ;; -;; - liblo like network wrapping -;; - error handling -;; - receiver -> osc-responder.lisp -;; - osc-tree as name.value alist for responder/serve-event -;; - portable en/decoding of floats -=> ieee754 tests -;; - bundles, blobs, doubles and other typetags -;; - asdf-installable - ;; known BUGS ;; - only unknown for now.. . -;; changes -;; -;; 2004-12-18 -;; - initial version, single args only -;; 2005-01-24 -;; - sends and receives multiple arguments -;; - tests in osc-test.lisp -;; 2005-01-26 -;; - fixed string handling bug -;; 2005-02-08 -;; - in-package'd -;; 2005-03-01 -;; - fixed address string bug -;; 2005-0305 -;; - 'declare' scattering and other optimisations (defpackage :osc (:use :cl) (:documentation "OSC aka the 'open sound control' protocol") (:export :encode-message - :decode-message)) + :encode-bundle + :decode-message + :decode-bundle)) (in-package :osc) -(declaim (optimize (speed 3) (safety 1))) +;(declaim (optimize (speed 3) (safety 1))) ;;;;;; ; ;; ; ; ; ; ; ; ; ;; @@ -76,6 +55,20 @@ ;; ;;; ;; ;; ; ; ;; ; ; ; ; + +(defun encode-bundle (data) + "will encode an osc message, or list of messages as a bundle + with an optional timetag. doesnt handle nested bundles" + (cat '(35 98 117 110 100 108 101 0) ; #bundle + (encode-timetag :now) + (if (listp (car data)) + (apply #'cat (mapcar #'encode-bundle-elt data)) + (encode-bundle-elt data)))) + +(defun encode-bundle-elt (data) + (let ((message (apply #'encode-message data))) + (cat (encode-int32 (length message)) message))) + (defun encode-message (address &rest data) "encodes an osc message with the given address and data." (concatenate '(vector (unsigned-byte 8)) @@ -85,7 +78,7 @@ (defun encode-address (address) (cat (map 'vector #'char-code address) - (pad-string address))) + (string-padding address))) (defun encode-typetags (data) "creates a typetag string suitable for the given data. @@ -93,10 +86,11 @@ non-std extensions include ,{h|t|d|S|c|r|m|T|F|N|I|[|]} see the spec for more details. .. - NOTE: currently handles the following tags only + NOTE: currently handles the following tags i => #(105) => int32 f => #(102) => float - s => #(115) => string" + s => #(115) => string + b => #(98) => blob" (let ((lump (make-array 0 :adjustable t :fill-pointer t @@ -110,6 +104,7 @@ (integer (write-to-vector #\i)) (float (write-to-vector #\f)) (simple-string (write-to-vector #\s)) + (simple-vector (write-to-vector #\b)) (t (error "can only encode ints, floats or strings")))) (cat lump (pad (padding-length (length lump))))))) @@ -123,67 +118,125 @@ (typecase x (integer (enc encode-int32)) (float (enc encode-float32)) - (simple-string (enc encode-string)) + (simple-string (enc encode-string)) + (simple-vector (enc encode-blob)) (t (error "wrong type. turn back")))) lump))) + ;;;;;; ; ;; ; ; ; ; ; ; ; ;; ;; decoding OSC messages ;; ;;; ;; ;; ; ; ; ; ; ; + +(defun decode-bundle (data) + "decodes an osc bundle into a list of decoded-messages, which has + an osc-timetagas its first element" + (let ((contents '())) + (if (equalp 35 (elt data 0)) ; a bundle begins with '#' + (let ((timetag (subseq data 8 16)) + (i 16) + (bundle-length (length data))) + (loop while (< i bundle-length) + do (let ((mark (+ i 4)) + (size (decode-int32 + (subseq data i (+ i 4))))) + (if (eq size 0) + (setf bundle-length 0) + (push (decode-bundle + (subseq data mark (+ mark size))) + contents)) + (incf i (+ 4 size)))) + (push timetag contents)) + (decode-message data)))) + (defun decode-message (message) - "reduces an osc message to an (address . data) pair. .." + "reduces an osc message to an (address . data) pair. .." (declare (type (vector *) message)) (let ((x (position (char-code #\,) message))) (if (eq x NIL) (format t "message contains no data.. ") (cons (decode-address (subseq message 0 x)) (decode-taged-data (subseq message x)))))) - + (defun decode-address (address) (coerce (map 'vector #'code-char (delete 0 address)) 'string)) - + (defun decode-taged-data (data) "decodes data encoded with typetags... - NOTE: currently handles the following tags only + NOTE: currently handles the following tags i => #(105) => int32 f => #(102) => float - s => #(115) => string" + s => #(115) => string + b => #(98) => blob" + + (let ((div (position 0 data))) + (let ((tags (subseq data 1 div)) + (acc (subseq data (padded-length div))) + (result '())) + (map 'vector + #'(lambda (x) + (cond + ((eq x (char-code #\i)) + (push (decode-int32 (subseq acc 0 4)) + result) + (setf acc (subseq acc 4))) + ((eq x (char-code #\f)) + (push (decode-float32 (subseq acc 0 4)) + result) + (setf acc (subseq acc 4))) + ((eq x (char-code #\s)) + (let ((pointer (padded-length (position 0 acc)))) + (push (decode-string + (subseq acc 0 pointer)) + result) + (setf acc (subseq acc pointer)))) + ((eq x (char-code #\b)) + (let ((size (decode-int32 (subseq acc 0 4)))) + (let ((end (padded-length (+ 4 size)))) + (push (decode-blob (subseq acc 0 end)) + result) + (setf acc (subseq acc end))))) + (t (error "unrecognised typetag")))) + tags) + (nreverse result)))) + + +;;; ; ;; ; +;; +;; timetags +;; +;; - not yet, but probably something using +;; (get-universal-time) > see also: CLHS 25.1.4 Time +;; or connecting to an ntp server.,. - ntpdate, ntpq +;; +;; - begin with bundles using 'now' as the timetag +;; - this should really handle 64bit fixed ints, +;; not signed 32bit ints +;; +;;;; ;; ; ; + +(defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) + +(defun encode-timetag (ut &optional subseconds) + "encodes an osc timetag from a universal-time and 32bit 'sub-second' part + for an 'instantaneous' timetag use (encode-timetag :now) " + (if (equalp ut :now) + #(0 0 0 0 0 0 0 1) + (cat (encode-int32 (+ ut +unix-epoch+)) + (encode-int32 (subseconds))))) + +(defun decode-timetag (timetag) + "decomposes a timetag into ut and a subsecond,. . ." + (list + (decode-int32 (subseq timetag 0 4)) + (decode-int32 (subseq timetag 4 8)))) - (setf div (position 0 data)) - (let ((tags (subseq data 1 div)) - (chunks (subseq data (osc-string-length (subseq data 0 div)))) - (acc '()) - (result '())) - (setf acc chunks) - (map 'vector - #'(lambda (x) - (cond - ((eq x (char-code #\i)) - (push (decode-int32 (subseq acc 0 4)) - result) - (setf acc (subseq acc 4))) - ((eq x (char-code #\f)) - (push (decode-float32 (subseq acc 0 4)) - result) - (setf acc (subseq acc 4))) - ((eq x (char-code #\s)) - (let ((pointer (+ (padding-length (position 0 acc)) - (position 0 acc)))) - (push (decode-string - (subseq acc 0 pointer)) - result) - (setf acc (subseq acc pointer)))) - ((eq x (char-code #\b)) (decode-blob x)) - (t (error "unrecognised typetag")))) - tags) - (nreverse result))) - ;;;;; ; ; ;; ;; ; ; ;; @@ -204,7 +257,6 @@ #-(or sbcl cmucl) (error "cant decode floats using this implementation")) (defun decode-int32 (s) - (declare (type (vector (unsigned-byte 8) s))) "4 byte > 32 bit int > two's compliment (in network byte order)" (let ((i (+ (ash (elt s 0) 24) (ash (elt s 1) 16) @@ -228,7 +280,7 @@ (set-byte 3)) buf)) - +;; osc-strings are unsigned bytes, padded to a 4 byte boundary (defun decode-string (data) "converts a binary vector to a string and removes trailing #\nul characters" @@ -237,33 +289,40 @@ (defun encode-string (string) "encodes a string as a vector of character-codes, padded to 4 byte boundary" (cat (map 'vector #'char-code string) - (pad-string string))) + (string-padding string))) -(defun decode-blob (b) - (error "cant decode blobs for now. ..")) +;; blobs are binary data, consisting of a length (int32) and bytes which are +;; osc-padded to a 4 byte boundary. -(defun encode-blob (b) - (error "cant encode blobs for now. ..")) +(defun decode-blob (blob) + "decode a blob as a vector of unsigned bytes." + (let ((size (decode-int32 + (subseq blob 0 4)))) + (subseq blob 4 (+ 4 size)))) + +(defun encode-blob (blob) + "encodes a blob from a given vector" + (let ((bl (length blob))) + (cat (encode-int32 bl) blob + (pad (padding-length bl))))) -;; utility functions for OSC slonking +;; utility functions for osc-string/padding slonking (defun cat (&rest catatac) (apply #'concatenate '(vector *) catatac)) -(defun osc-string-length (string) - "determines the length required for a padded osc string" - (declare (type simple-string string)) - (let ((n (length string))) - (declare (type fixnum n)) - (+ n (padding-length n)))) - (defun padding-length (s) "returns the length of padding required for a given length of string" (declare (type fixnum s)) (- 4 (mod s 4))) -(defun pad-string (string) +(defun padded-length (s) + "returns the length of an osc-string made from a given length of string" + (declare (type fixnum s)) + (+ s (- 4 (mod s 4)))) + +(defun string-padding (string) "returns the padding required for a given osc string" (declare (type simple-string string)) (pad (- 4 (mod (length string) 4))))