podoscaph

#bundle support added to the feet. small step towards watertightness

darcs-hash:20050314140505-2648a-268ae71e964c269e196c590d867970411d786804.gz
This commit is contained in:
nik gaffney 2005-03-14 22:05:05 +08:00
parent c7a22c9e4a
commit f8cc808c44
4 changed files with 209 additions and 102 deletions

View file

@ -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 -> This is a common-lisp implementation of the Open Sound Control
- specific info about what is/isnt working can be found in the header of osc.lisp Protocol, aka OSC. The code should be close to ansi standard, and does
- more details about OSC can be found at 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/ http://www.cnmat.berkeley.edu/OpenSoundControl/
- current versions of this code can be found at http://fo.am/darcs/osc
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

View file

@ -33,7 +33,7 @@
(in-package :osc) (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. ;; for now, a hash table is enuf.
(defun make-osc-tree () (defun make-osc-tree ()

View file

@ -29,19 +29,19 @@
(require :sb-bsd-sockets) (require :sb-bsd-sockets)
(use-package :osc) (use-package :osc)
(use-package :sb-bsd-sockets)
(defun osc-listen (port) (defun osc-listen (port)
"a basic test function which attempts to decode osc stuff a "a basic test function which attempts to decode an osc message a given port."
given port. default ogreOSC port is 4178"
(let ((s (make-udp-socket)) (let ((s (make-udp-socket))
(buffer (make-sequence '(vector (unsigned-byte 8)) 1024))) (buffer (make-sequence '(vector (unsigned-byte 8)) 1024)))
(socket-bind s #(0 0 0 0) port) (socket-bind s #(0 0 0 0) port)
(format t "listening on localhost port ~A~%~%" port) (format t "listening on localhost port ~A~%~%" port)
(unwind-protect (unwind-protect
(loop do (loop do
(socket-receive s buffer nil :waitall t) (socket-receive s buffer nil)
(format t "receiveded -=> ~S~%" (osc:decode-message buffer))) (format t "receiveded -=> ~S~%" (osc:decode-bundle buffer)))
(when s (socket-close s))))) (when s (socket-close s)))))
@ -59,10 +59,10 @@
:element-type '(unsigned-byte 8) :buffering :full))) :element-type '(unsigned-byte 8) :buffering :full)))
(unwind-protect (unwind-protect
(loop do (loop do
(socket-receive in buffer nil :waitall t) (socket-receive in buffer nil)
(let ((oscuff (osc:decode-message buffer))) (let ((oscuff (osc:decode-bundle buffer)))
(format t "glonked -=> message with ~S~% arg(s)" (length oscuff)) (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 in (socket-close in))
(when out (socket-close out)))))) (when out (socket-close out))))))
@ -70,7 +70,7 @@
(defun make-udp-socket() (defun make-udp-socket()
(make-instance 'inet-socket :type :datagram :protocol :udp)) (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 "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) stream any funtion writing to the stream should call (finish-output stream)
after it sends the mesages,. ." after it sends the mesages,. ."

173
osc.lisp
View file

@ -27,48 +27,27 @@
;; of the protocol can be found at the open sound control pages -=> ;; of the protocol can be found at the open sound control pages -=>
;; http://www.cnmat.berkeley.edu/OpenSoundControl/ ;; http://www.cnmat.berkeley.edu/OpenSoundControl/
;; ;;
;; - currently doesnt send timetags, but does send typetags ;; - doesnt send nested bundles or timetags later than 'now'
;; - will most likely crash if the input is malformed ;; - will most likely crash if the input is malformed
;; - int32 en/de-coding based on code (c) Walter C. Pelissero ;; - int32 en/de-coding based on code (c) Walter C. Pelissero
;; to do
;; ;;
;; - liblo like network wrapping ;; see the README file for more details...
;; - 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 ;; known BUGS
;; - only unknown for now.. . ;; - 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 (defpackage :osc
(:use :cl) (:use :cl)
(:documentation "OSC aka the 'open sound control' protocol") (:documentation "OSC aka the 'open sound control' protocol")
(:export :encode-message (:export :encode-message
:decode-message)) :encode-bundle
:decode-message
:decode-bundle))
(in-package :osc) (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) (defun encode-message (address &rest data)
"encodes an osc message with the given address and data." "encodes an osc message with the given address and data."
(concatenate '(vector (unsigned-byte 8)) (concatenate '(vector (unsigned-byte 8))
@ -85,7 +78,7 @@
(defun encode-address (address) (defun encode-address (address)
(cat (map 'vector #'char-code address) (cat (map 'vector #'char-code address)
(pad-string address))) (string-padding address)))
(defun encode-typetags (data) (defun encode-typetags (data)
"creates a typetag string suitable for the given 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|[|]} non-std extensions include ,{h|t|d|S|c|r|m|T|F|N|I|[|]}
see the spec for more details. .. see the spec for more details. ..
NOTE: currently handles the following tags only NOTE: currently handles the following tags
i => #(105) => int32 i => #(105) => int32
f => #(102) => float f => #(102) => float
s => #(115) => string" s => #(115) => string
b => #(98) => blob"
(let ((lump (make-array 0 :adjustable t (let ((lump (make-array 0 :adjustable t
:fill-pointer t :fill-pointer t
@ -110,6 +104,7 @@
(integer (write-to-vector #\i)) (integer (write-to-vector #\i))
(float (write-to-vector #\f)) (float (write-to-vector #\f))
(simple-string (write-to-vector #\s)) (simple-string (write-to-vector #\s))
(simple-vector (write-to-vector #\b))
(t (error "can only encode ints, floats or strings")))) (t (error "can only encode ints, floats or strings"))))
(cat lump (cat lump
(pad (padding-length (length lump))))))) (pad (padding-length (length lump)))))))
@ -124,16 +119,40 @@
(integer (enc encode-int32)) (integer (enc encode-int32))
(float (enc encode-float32)) (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")))) (t (error "wrong type. turn back"))))
lump))) lump)))
;;;;;; ; ;; ; ; ; ; ; ; ; ;;;;;; ; ;; ; ; ; ; ; ; ;
;; ;;
;; decoding OSC messages ;; 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) (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)) (declare (type (vector *) message))
@ -150,17 +169,16 @@
(defun decode-taged-data (data) (defun decode-taged-data (data)
"decodes data encoded with typetags... "decodes data encoded with typetags...
NOTE: currently handles the following tags only NOTE: currently handles the following tags
i => #(105) => int32 i => #(105) => int32
f => #(102) => float f => #(102) => float
s => #(115) => string" s => #(115) => string
b => #(98) => blob"
(setf div (position 0 data)) (let ((div (position 0 data)))
(let ((tags (subseq data 1 div)) (let ((tags (subseq data 1 div))
(chunks (subseq data (osc-string-length (subseq data 0 div)))) (acc (subseq data (padded-length div)))
(acc '())
(result '())) (result '()))
(setf acc chunks)
(map 'vector (map 'vector
#'(lambda (x) #'(lambda (x)
(cond (cond
@ -173,16 +191,51 @@
result) result)
(setf acc (subseq acc 4))) (setf acc (subseq acc 4)))
((eq x (char-code #\s)) ((eq x (char-code #\s))
(let ((pointer (+ (padding-length (position 0 acc)) (let ((pointer (padded-length (position 0 acc))))
(position 0 acc))))
(push (decode-string (push (decode-string
(subseq acc 0 pointer)) (subseq acc 0 pointer))
result) result)
(setf acc (subseq acc pointer)))) (setf acc (subseq acc pointer))))
((eq x (char-code #\b)) (decode-blob x)) ((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")))) (t (error "unrecognised typetag"))))
tags) tags)
(nreverse result))) (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))))
;;;;; ; ; ;; ;; ; ; ;;;;; ; ; ;; ;; ; ;
@ -204,7 +257,6 @@
#-(or sbcl cmucl) (error "cant decode floats using this implementation")) #-(or sbcl cmucl) (error "cant decode floats using this implementation"))
(defun decode-int32 (s) (defun decode-int32 (s)
(declare (type (vector (unsigned-byte 8) s)))
"4 byte > 32 bit int > two's compliment (in network byte order)" "4 byte > 32 bit int > two's compliment (in network byte order)"
(let ((i (+ (ash (elt s 0) 24) (let ((i (+ (ash (elt s 0) 24)
(ash (elt s 1) 16) (ash (elt s 1) 16)
@ -228,7 +280,7 @@
(set-byte 3)) (set-byte 3))
buf)) buf))
;; osc-strings are unsigned bytes, padded to a 4 byte boundary
(defun decode-string (data) (defun decode-string (data)
"converts a binary vector to a string and removes trailing #\nul characters" "converts a binary vector to a string and removes trailing #\nul characters"
@ -237,33 +289,40 @@
(defun encode-string (string) (defun encode-string (string)
"encodes a string as a vector of character-codes, padded to 4 byte boundary" "encodes a string as a vector of character-codes, padded to 4 byte boundary"
(cat (map 'vector #'char-code string) (cat (map 'vector #'char-code string)
(pad-string string))) (string-padding string)))
(defun decode-blob (b) ;; blobs are binary data, consisting of a length (int32) and bytes which are
(error "cant decode blobs for now. ..")) ;; osc-padded to a 4 byte boundary.
(defun encode-blob (b) (defun decode-blob (blob)
(error "cant encode blobs for now. ..")) "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) (defun cat (&rest catatac)
(apply #'concatenate '(vector *) 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) (defun padding-length (s)
"returns the length of padding required for a given length of string" "returns the length of padding required for a given length of string"
(declare (type fixnum s)) (declare (type fixnum s))
(- 4 (mod s 4))) (- 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" "returns the padding required for a given osc string"
(declare (type simple-string string)) (declare (type simple-string string))
(pad (- 4 (mod (length string) 4)))) (pad (- 4 (mod (length string) 4))))