zzkt/osc
1
0
Fork 0
Code Issues 7 Pull requests Projects Releases Activity Actions

podoscaph

Browse source 
#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
Show stats Download patch file Download diff file Expand all files Collapse all files

62
README.txt
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 ->
- 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

2
osc-dispatch.lisp
View file

@ -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 ()

18
osc-examples.lisp
View file

@ -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,. ."

229
osc.lisp
View file

@ -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 <nik@f0.am>
@ -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))))