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

timetags, nested bundles, higher-level API and various tweaks #2

Closed
jamieforth wants to merge 24 commits from master into master
pull from: master
merge into: zzkt:master
Conversation 5 Commits 24 Files changed 16 +401 -398
13 changed files with 401 additions and 398 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files
Showing only changes of commit 03b078c20f - Show all commits

94
devices/client.lisp
View file

@ -1,25 +1,25 @@
(cl:in-package #:osc)
(defun make-osc-client (&key(protocol :udp) debug-mode
(buffer-size *default-osc-buffer-size*)
address-tree cleanup-fun)
(buffer-size *default-osc-buffer-size*)
address-tree cleanup-fun)
(ecase protocol
(:udp (make-instance 'osc-client-udp
:debug-mode debug-mode
:socket-buffer (make-socket-buffer
buffer-size)
:address-tree (if address-tree
address-tree
(make-osc-tree))
:cleanup-fun cleanup-fun))
:debug-mode debug-mode
:socket-buffer (make-socket-buffer
buffer-size)
:address-tree (if address-tree
address-tree
(make-osc-tree))
:cleanup-fun cleanup-fun))
(:tcp (make-instance 'osc-client-tcp
:debug-mode debug-mode
:socket-buffer (make-socket-buffer
buffer-size)
:address-tree (if address-tree
address-tree
(make-osc-tree))
:cleanup-fun cleanup-fun))))
:debug-mode debug-mode
:socket-buffer (make-socket-buffer
buffer-size)
:address-tree (if address-tree
address-tree
(make-osc-tree))
:cleanup-fun cleanup-fun))))
(defmethod initialize-instance :after ((client osc-client-udp) &key)
(make-client-responders client))
@ -30,11 +30,11 @@
(add-osc-responder client "/cl-osc/server/registered"
(cmd args device address port timetag)
(format t "Registered with server at ~A~%"
(make-addr+port-string address port)))
(make-addr+port-string address port)))
(add-osc-responder client "/cl-osc/server/quit"
(cmd args device address port timetag)
(format t "Server ~A has quit~%"
(make-addr+port-string address port))))
(make-addr+port-string address port))))
(defgeneric register (client)
(:method ((client osc-client-udp))
@ -45,19 +45,19 @@
(call-next-method))
(defun make-osc-client-endpoint-tcp (socket debug-mode buffer-size
address-tree clients &optional
cleanup-fun)
address-tree clients &optional
cleanup-fun)
(socket-make-stream socket
:input nil :output t
:element-type '(unsigned-byte 8)
:buffering :full)
:input nil :output t
:element-type '(unsigned-byte 8)
:buffering :full)
(let ((client (make-instance 'osc-client-endpoint-tcp
:debug-mode debug-mode
:address-tree address-tree
:socket-buffer (make-socket-buffer
buffer-size)
:clients clients
:cleanup-fun cleanup-fun)))
:debug-mode debug-mode
:address-tree address-tree
:socket-buffer (make-socket-buffer
buffer-size)
:clients clients
:cleanup-fun cleanup-fun)))
(set-socket socket client)
(set-listening-thread (make-listening-thread client) client)
client))
@ -67,21 +67,21 @@
(sb-thread:make-thread
(lambda ()
(unwind-protect
(loop
do (multiple-value-bind (buffer length address port)
(socket-receive (socket receiver)
(socket-buffer receiver) nil)
(when (eq length 0) ; Closed by remote
(sb-thread:terminate-thread
sb-thread:*current-thread*))
(multiple-value-bind (message timetag)
(decode-bundle buffer length)
(when (debug-mode receiver)
(print-osc-debug-msg receiver message length
(peer-address receiver)
(peer-port receiver) timetag))
(dispatch (address-tree receiver) message receiver
address port timetag))))
(osc-device-cleanup receiver)))
:name (format nil "osc-client-tcp-connection: ~A~%"
(name receiver))))
(loop
do (multiple-value-bind (buffer length address port)
(socket-receive (socket receiver)
(socket-buffer receiver) nil)
(when (eq length 0) ; Closed by remote
(sb-thread:terminate-thread
sb-thread:*current-thread*))
(multiple-value-bind (message timetag)
(decode-bundle buffer length)
(when (debug-mode receiver)
(print-osc-debug-msg receiver message length
(peer-address receiver)
(peer-port receiver) timetag))
(dispatch (address-tree receiver) message receiver
address port timetag))))
(osc-device-cleanup receiver)))
:name (format nil "osc-client-tcp-connection: ~A~%"
(name receiver))))

22
devices/device.lisp
View file

@ -45,7 +45,7 @@
:initform (make-osc-tree))))
(defclass dispatching-device-udp (dispatching-device receiving-device
udp-device) ())
udp-device) ())
;;;=====================================================================
@ -55,7 +55,7 @@
(defclass osc-transmitter (osc-device) ())
(defclass osc-client (dispatching-device receiving-device
osc-transmitter) ())
osc-transmitter) ())
(defclass osc-server (dispatching-device osc-transmitter)
((buffer-size
@ -70,7 +70,7 @@
((clients
:reader clients
:initarg :clients)))
;;;=====================================================================
;;; OSC device concrete classes
@ -83,12 +83,12 @@
(defclass osc-client-tcp (osc-client tcp-device) ())
(defclass osc-server-udp (osc-server dispatching-device-udp
osc-transmitter-udp) ())
osc-transmitter-udp) ())
(defclass osc-server-tcp (osc-server osc-transmitter tcp-device) ())
(defclass osc-client-endpoint-tcp (osc-client-endpoint
osc-client-tcp) ())
osc-client-tcp) ())
;;;=====================================================================
@ -104,9 +104,9 @@
(defgeneric name (osc-device)
(:method ((osc-device osc-device))
(concatenate 'string
(symbol-name (class-name (class-of osc-device)))
"-"
(make-name-string osc-device))))
(symbol-name (class-name (class-of osc-device)))
"-"
(make-name-string osc-device))))
(defmethod buffer-size ((osc-device dispatching-device))
(length (socket-buffer osc-device)))
@ -115,12 +115,12 @@
(defgeneric osc-device-cleanup (device)
(:method :before ((osc-device osc-device))
(when (cleanup-fun osc-device)
(funcall (cleanup-fun osc-device) osc-device)))
(when (cleanup-fun osc-device)
(funcall (cleanup-fun osc-device) osc-device)))
(:method ((osc-device osc-device))
(when (debug-mode osc-device)
(format t "~%OSC device stopped: ~A~%"
(name osc-device)))
(name osc-device)))
(when (socket osc-device)
(handler-case
(socket-close (socket osc-device) :abort t)

33
devices/dispatching-device.lisp
View file

@ -5,17 +5,17 @@
(sb-thread:make-thread
(lambda ()
(unwind-protect
(loop
do (multiple-value-bind (buffer length address port)
(socket-receive (socket receiver)
(socket-buffer receiver) nil)
(multiple-value-bind (message timetag)
(osc:decode-bundle buffer length)
(when (debug-mode receiver)
(print-osc-debug-msg receiver message length address
port timetag))
(osc:dispatch (address-tree receiver) message
receiver address port timetag))))
(loop
do (multiple-value-bind (buffer length address port)
(socket-receive (socket receiver)
(socket-buffer receiver) nil)
(multiple-value-bind (message timetag)
(osc:decode-bundle buffer length)
(when (debug-mode receiver)
(print-osc-debug-msg receiver message length
address port timetag))
(osc:dispatch (address-tree receiver) message
receiver address port timetag))))
(osc-device-cleanup receiver)))
:name (format nil "osc-receiver-udp: ~A~%" (name receiver))))
@ -25,12 +25,13 @@
;;;=====================================================================
(defmacro add-osc-responder (dispatcher cmd-name
(cmd args disp addr port timetag) &body
body)
(cmd args disp addr port timetag) &body
body)
`(dp-register (address-tree ,dispatcher) ,cmd-name
(lambda (,cmd ,args ,disp ,addr ,port ,timetag)
(declare (ignorable ,cmd ,args ,disp ,addr
,port ,timetag)) ,@body)))
(lambda (,cmd ,args ,disp ,addr ,port ,timetag)
(declare (ignorable ,cmd ,args ,disp ,addr
,port ,timetag))
,@body)))
(defgeneric remove-osc-responder (dispatcher address)
(:method ((dispatcher dispatching-device) address)

4
devices/examples/osc-device-examples.lisp
View file

@ -99,7 +99,7 @@
(add-osc-responder *osc-client* "/echo-answer"
(cmd args device address port timetag)
(format t "~%Sum is ~A" (car args)))
(send *osc-client* "/echo-sum" 1 2 3 4)
(add-osc-responder *osc-server* "/timetag+1"
@ -220,7 +220,7 @@ n=NetAddr("localhost", 57127)
e=OSCresponder(nil,
'/echo-sum',
{|t,r,msg,addr|
{|t,r,msg,addr|
[t,r,msg,addr].postln;
}).add

12
devices/listening-device.lisp
View file

@ -3,10 +3,10 @@
(defgeneric make-listening-thread (listening-device))
(defmethod connect progn ((listening-device listening-device)
host-port &key host-address host-name port)
host-port &key host-address host-name port)
(declare (ignore host-port host-address host-name port))
(set-listening-thread (make-listening-thread listening-device)
listening-device))
listening-device))
(defmethod quit ((device listening-device))
(sb-thread:terminate-thread (listening-thread device)))
@ -20,8 +20,8 @@
(call-next-method))
(defun print-osc-debug-msg (receiver message length address port
timetag)
timetag)
(format t "~%~A~%received:~A~A~%bytes:~A~A~A~%from:~A~A~A ~A ~%timetag:~A~A~%unix-time:~A~F~%"
(name receiver) #\Tab message #\Tab #\Tab length #\Tab #\Tab
address port #\Tab timetag #\Tab
(when timetag (timetag->unix-time timetag))))
(name receiver) #\Tab message #\Tab #\Tab length #\Tab #\Tab
address port #\Tab timetag #\Tab
(when timetag (timetag->unix-time timetag))))

84
devices/server.lisp
View file

@ -1,17 +1,17 @@
(cl:in-package #:osc)
(defun make-osc-server (&key (protocol :udp) debug-mode
(buffer-size *default-osc-buffer-size*)
cleanup-fun)
(buffer-size *default-osc-buffer-size*)
cleanup-fun)
(ecase protocol
(:udp (make-instance 'osc-server-udp
:debug-mode debug-mode
:cleanup-fun cleanup-fun
:buffer-size buffer-size))
:debug-mode debug-mode
:cleanup-fun cleanup-fun
:buffer-size buffer-size))
(:tcp (make-instance 'osc-server-tcp
:debug-mode debug-mode
:cleanup-fun cleanup-fun
:buffer-size buffer-size))))
:debug-mode debug-mode
:cleanup-fun cleanup-fun
:buffer-size buffer-size))))
(defgeneric boot (osc-server port))
@ -22,7 +22,7 @@
(socket-bind (socket server) #(0 0 0 0) port)
(call-next-method)
(format t "~%Server ~A listening on port ~A~%"
(machine-instance) port))
(machine-instance) port))
(defmethod boot ((server osc-server-udp) port)
(declare (ignore port))
@ -35,17 +35,17 @@
(sb-thread:make-thread
(lambda ()
(unwind-protect
(progn (socket-listen (socket server) 10)
(loop for socket = (socket-accept (socket server))
for endpoint = (make-osc-client-endpoint-tcp
socket
(debug-mode server)
(buffer-size server)
(address-tree server)
(clients server)
(make-unregister-self-fun server))
do (register-tcp-client server endpoint)))
(osc-device-cleanup server)))
(progn (socket-listen (socket server) 10)
(loop for socket = (socket-accept (socket server))
for endpoint = (make-osc-client-endpoint-tcp
socket
(debug-mode server)
(buffer-size server)
(address-tree server)
(clients server)
(make-unregister-self-fun server))
do (register-tcp-client server endpoint)))
(osc-device-cleanup server)))
:name (format nil "osc-server-tcp: ~A" (name server)))
server)
server)
@ -55,8 +55,8 @@
using (hash-value addr+port)
do (notify-quit device client-name)
do (unregister-udp-client device
(first addr+port)
(second addr+port)))
(first addr+port)
(second addr+port)))
(call-next-method))
(defmethod osc-device-cleanup ((device osc-server-tcp))
@ -81,9 +81,9 @@
(add-osc-responder server "/cl-osc/register"
(cmd args device address port timetag)
(let ((listening-port (car args))) ; Optional port for sending
; return messages to.
; return messages to.
(register-udp-client device address
(if listening-port listening-port port))))
(if listening-port listening-port port))))
(add-osc-responder server "/cl-osc/quit"
(cmd args device address port timetag)
(unregister-udp-client device address port)))
@ -92,7 +92,7 @@
(let ((client-name (make-addr+port-string addr port)))
(format t "Client registered: ~A~%" client-name)
(setf (gethash client-name (clients server))
(list addr port))
(list addr port))
(post-register-hook server client-name)))
(defun unregister-udp-client (server addr port)
@ -143,15 +143,15 @@ the peername independently of the socket's connection status?"
(loop for addr+port being the hash-value in (clients server)
for i from 1
do (format t "~A. Connected to: ~A~%" i (make-addr+port-string
(first addr+port)
(second addr+port)))))
(first addr+port)
(second addr+port)))))
(defmethod print-clients ((server osc-server-tcp))
(loop for endpoint being the hash-value in (clients server)
for i from 1
do (format t "~A. Connected to: ~A~%" i (make-addr+port-string
(peer-address endpoint)
(peer-port endpoint)))))
(peer-address endpoint)
(peer-port endpoint)))))
;;;=====================================================================
;;; Server sending functions
@ -159,28 +159,28 @@ the peername independently of the socket's connection status?"
(defgeneric send-to-client (server client-name &rest msg)
(:method :around ((server osc-server) client-name &rest msg)
(let ((client (gethash client-name (clients server))))
(if client
(apply #'call-next-method server client msg)
(warn "No client called ~A~%" client-name)))))
(let ((client (gethash client-name (clients server))))
(if client
(apply #'call-next-method server client msg)
(warn "No client called ~A~%" client-name)))))
(defmethod send-to-client ((server osc-server-udp) client-name &rest
msg)
msg)
(apply #'send-to server (first client-name) (second client-name)
msg))
msg))
(defmethod send-to-client ((server osc-server-tcp) client &rest msg)
(apply #'send client msg))
(defgeneric send-bundle-to-client (server client-name timetag &rest
msg)
msg)
(:method :around ((server osc-server) client-name timetag &rest msg)
(let ((client (gethash client-name (clients server))))
(if client
(apply #'call-next-method server client timetag msg)
(warn "No client called ~A~%" client-name)))))
(let ((client (gethash client-name (clients server))))
(if client
(apply #'call-next-method server client timetag msg)
(warn "No client called ~A~%" client-name)))))
(defmethod send-bundle-to-client ((server osc-server-udp) client-name
timetag &rest msg)
timetag &rest msg)
(apply #'send-bundle-to server (first client-name)
(second client-name) timetag msg))
(second client-name) timetag msg))

2
devices/socket-functions.lisp
View file

@ -25,7 +25,7 @@
(defun make-name-string (osc-device)
(when (socket osc-device)
(multiple-value-bind (addr port)
(socket-name (socket osc-device))
(socket-name (socket osc-device))
(make-addr+port-string addr port))))
(defun make-addr+port-string (addr port)

88
devices/transmitter.lisp
View file

@ -4,44 +4,44 @@
(defun make-osc-transmitter (&key debug-mode cleanup-fun)
(make-instance 'osc-transmitter-udp
:debug-mode debug-mode
:cleanup-fun cleanup-fun))
:debug-mode debug-mode
:cleanup-fun cleanup-fun))
(defgeneric connect (osc-transmitter host-port &key host-address
host-name port)
host-name port)
(:method-combination progn :most-specific-last))
(defmethod connect progn ((transmitter osc-transmitter) host-port
&key (host-address nil addr)
(host-name "localhost" name) port)
&key (host-address nil addr)
(host-name "localhost" name) port)
(when (and addr name)
(error "Supplied both :host-address and :host-name to connect"))
(cond (addr
(when (typep host-address 'string)
(setf host-address
(sb-bsd-sockets:make-inet-address host-address))))
(t
(setf host-address
(sb-bsd-sockets:host-ent-address
(sb-bsd-sockets:get-host-by-name
host-name)))))
(when (typep host-address 'string)
(setf host-address
(sb-bsd-sockets:make-inet-address host-address))))
(t
(setf host-address
(sb-bsd-sockets:host-ent-address
(sb-bsd-sockets:get-host-by-name
host-name)))))
(if (not (device-active-p transmitter))
(progn
(let ((socket (make-socket (protocol transmitter))))
(if port
(socket-bind socket #(127 0 0 1) port)
(socket-bind socket))
(socket-connect socket host-address host-port)
(socket-make-stream socket
:input nil :output t
:element-type '(unsigned-byte 8)
:buffering :full)
(set-socket socket transmitter))
(when (debug-mode transmitter)
(format t "~%Device connected: ~A~%~A -> ~A~%"
(name transmitter) #\Tab
(make-addr+port-string (peer-address transmitter)
(peer-port transmitter)))))
(let ((socket (make-socket (protocol transmitter))))
(if port
(socket-bind socket #(127 0 0 1) port)
(socket-bind socket))
(socket-connect socket host-address host-port)
(socket-make-stream socket
:input nil :output t
:element-type '(unsigned-byte 8)
:buffering :full)
(set-socket socket transmitter))
(when (debug-mode transmitter)
(format t "~%Device connected: ~A~%~A -> ~A~%"
(name transmitter) #\Tab
(make-addr+port-string (peer-address transmitter)
(peer-port transmitter)))))
(warn "Already connected"))
transmitter)
@ -57,36 +57,36 @@
(defmacro osc-write-to-stream (stream &body msg)
`(progn (write-sequence ,@msg ,stream)
(finish-output ,stream)))
(finish-output ,stream)))
(defgeneric send (transmitter &rest msg-args)
(:method ((transmitter osc-transmitter) &rest msg-args)
(let ((msg (apply #'encode-message msg-args)))
(osc-write-to-stream
(slot-value (socket transmitter) 'stream) msg))))
(slot-value (socket transmitter) 'stream) msg))))
(defgeneric send-bundle (transmitter timetag &rest msg-args)
(:method ((transmitter osc-transmitter) timetag &rest msg-args)
(let ((msg (encode-bundle msg-args timetag)))
(osc-write-to-stream
(slot-value (socket transmitter) 'stream) msg))))
(slot-value (socket transmitter) 'stream) msg))))
;; Unconnected sending
(defgeneric send-to (transmitter address port &rest msg-args)
(:method ((transmitter osc-transmitter-udp) address port &rest
msg-args)
msg-args)
(socket-send (socket transmitter)
(apply #'encode-message msg-args) nil
:address (list address port))))
(apply #'encode-message msg-args) nil
:address (list address port))))
(defgeneric send-bundle-to (transmitter address port timestamp &rest
msg-args)
msg-args)
(:method ((transmitter osc-transmitter-udp) address port timestamp
&rest msg-args)
&rest msg-args)
(socket-send (socket transmitter)
(apply #'encode-bundle msg-args (list timestamp)) nil
:address (list address port))))
(apply #'encode-bundle msg-args (list timestamp)) nil
:address (list address port))))
;; Server functions
@ -95,14 +95,14 @@
(defmethod send-all ((server osc-server-udp) &rest msg-args)
(loop for addr+port being the hash-value in (clients server)
do (apply #'send-to server (first addr+port) (second addr+port)
msg-args)))
msg-args)))
(defmethod send-all ((server osc-server-tcp) &rest msg-args)
(loop for endpoint being the hash-value in (clients server)
do (apply #'send endpoint msg-args)))
(defmethod send-all ((client-endpoint osc-client-endpoint) &rest
msg-args)
msg-args)
(loop for endpoint being the hash-value in (clients client-endpoint)
unless (eq endpoint client-endpoint) ; don't send to sender
do (apply #'send endpoint msg-args)))
@ -110,18 +110,18 @@
(defgeneric send-bundle-all (server timetag &rest msg-args))
(defmethod send-bundle-all ((server osc-server-udp) timetag &rest
msg-args)
msg-args)
(loop for addr+port being the hash-value in (clients server)
do (apply #'send-bundle-to server (first addr+port)
(second addr+port) timetag msg-args)))
(second addr+port) timetag msg-args)))
(defmethod send-bundle-all ((server osc-server-tcp) timetag &rest
msg-args)
msg-args)
(loop for endpoint being the hash-value in (clients server)
do (apply #'send-bundle endpoint timetag msg-args)))
(defmethod send-bundle-all ((client-endpoint osc-client-endpoint)
timetag &rest msg-args)
timetag &rest msg-args)
(loop for endpoint being the hash-value in (clients client-endpoint)
unless (eq endpoint client-endpoint) ; don't send to sender
do (apply #'send-bundle endpoint timetag msg-args)))

10
osc-dispatch.lisp
View file

@ -51,23 +51,23 @@
only one function should be associated with an address, any
previous registration will be overwritten"
(setf (gethash address tree)
function))
function))
(defun dp-remove (tree address)
"removes the function associated with the given address.."
(remhash address tree))
(defun dp-match (tree pattern)
"returns a list of functions which are registered for
dispatch for a given address pattern.."
"returns a list of functions which are registered for dispatch for a
given address pattern.."
(list (gethash pattern tree)))
(defun dispatch (tree osc-message &optional device address port
timetag)
timetag)
"calls the function(s) matching the address(pattern) in the osc
message with the data contained in the message"
(let ((pattern (car osc-message)))
(dolist (x (dp-match tree pattern))
(unless (eq x NIL)
(funcall x (car osc-message) (cdr osc-message) device address
port timetag)))))
port timetag)))))

59
osc-examples.lisp
View file

@ -1,7 +1,7 @@
;; -*- mode: lisp -*-
;;
;; Examples of how to send OSC messages. ..
;;
;;
;; Copyright (C) 2004 FoAM vzw
;;
;; Authors
@ -17,9 +17,9 @@
;; work with trivial-sockets, acl-compat or something similar. They should be
;; able to explain enough to get you started. ..
;;
;; eg. listen on port 6667 for incoming msgs
;; eg. listen on port 6667 for incoming msgs
;;
;; (osc-listen 6667)
;; (osc-listen 6667)
;;
;; eg. listen on port 6667 and send to 10.0.89:6668
;; note the ip# is formatted as a vector
@ -33,55 +33,56 @@
(use-package :sb-bsd-sockets)
(defun osc-listen (port)
(defun osc-listen (port)
"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)
(format t "receiveded -=> ~S~%" (osc:decode-bundle buffer)))
(when s (socket-close s)))))
(unwind-protect
(loop do
(socket-receive s buffer nil)
(format t "receiveded -=> ~S~%" (osc:decode-bundle buffer)))
(when s (socket-close s)))))
(defun osc-reflector (listen-port send-ip send-port)
(defun osc-reflector (listen-port send-ip send-port)
"reflector.. . listens on a given port and sends out on another
note ip#s need to be in the format #(127 0 0 1) for now.. ."
(let ((in (make-udp-socket))
(out (make-udp-socket))
(buffer (make-sequence '(vector (unsigned-byte 8)) 512)))
(buffer (make-sequence '(vector (unsigned-byte 8)) 512)))
(socket-bind in #(0 0 0 0) listen-port)
(socket-connect out send-ip send-port)
(let ((stream
(socket-make-stream
out :input t :output t
:element-type '(unsigned-byte 8) :buffering :full)))
(unwind-protect
(loop do
(socket-receive in buffer nil)
(let ((oscuff (osc:decode-bundle buffer)))
(format t "glonked -=> message with ~S~% arg(s)" (length oscuff))
(write-stream-t1 stream oscuff)))
(when in (socket-close in))
(when out (socket-close out))))))
(let ((stream
(socket-make-stream
out :input t :output t
:element-type '(unsigned-byte 8) :buffering :full)))
(unwind-protect
(loop do
(socket-receive in buffer nil)
(let ((oscuff (osc:decode-bundle buffer)))
(format t "glonked -=> message with ~S~% arg(s)"
(length oscuff))
(write-stream-t1 stream oscuff)))
(when in (socket-close in))
(when out (socket-close out))))))
(defun make-udp-socket()
(make-instance 'inet-socket :type :datagram :protocol :udp))
(defun write-stream-t1 (stream osc-message)
"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,. ."
(write-sequence
(defun write-stream-t1 (stream osc-message)
"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,. ."
(write-sequence
(osc:encode-message "/bzzp" "got" "it" )
stream)
(finish-output stream))
(defmacro osc-write-to-stream (stream &body args)
`(progn (write-sequence (osc:encode-message ,@args) ,stream)
(finish-output ,stream)))
(finish-output ,stream)))
;end

30
osc-time.lisp
View file

@ -11,17 +11,17 @@
(typep object 'timetag))
(defun unix-secs+usecs->timetag (secs usecs)
(let ((sec-offset (+ secs +unix-epoch+))) ; Seconds from 1900.
(setf sec-offset (ash sec-offset 32)) ; Make seconds the top
; 32 bits.
(let ((usec-offset
(round (* usecs +2^32/MILLION+)))) ; Fractional part.
(the timetag (+ sec-offset usec-offset)))))
(let ((sec-offset (+ secs +unix-epoch+))) ; Seconds from 1900.
(setf sec-offset (ash sec-offset 32)) ; Make seconds the top 32
; bits.
(let ((usec-offset
(round (* usecs +2^32/MILLION+)))) ; Fractional part.
(the timetag (+ sec-offset usec-offset)))))
(defun get-current-timetag ()
"Returns a fixed-point 64 bit NTP-style timetag, where the top
32 bits represent seconds since midnight 19000101, and the bottom 32
bits represent the fractional parts of a second."
"Returns a fixed-point 64 bit NTP-style timetag, where the top 32
bits represent seconds since midnight 19000101, and the bottom 32 bits
represent the fractional parts of a second."
(multiple-value-bind (secs usecs)
(sb-ext:get-time-of-day)
(the timetag (unix-secs+usecs->timetag secs usecs))))
@ -47,16 +47,16 @@ with microsecond precision, relative to 19700101."
(multiple-value-bind (secs subsecs)
(floor unix-time)
(the timetag
(unix-secs+usecs->timetag secs
(subsecs->microseconds subsecs)))))
(unix-secs+usecs->timetag secs
(subsecs->microseconds subsecs)))))
(defun timetag->unix-time (timetag)
(if (= timetag 1)
1 ; immediate timetag
1 ; immediate timetag
(let* ((secs (ash timetag -32))
(subsec-int32 (- timetag (ash secs 32))))
(the double-float (+ (- secs +unix-epoch+)
(int32->subsecs subsec-int32))))))
(subsec-int32 (- timetag (ash secs 32))))
(the double-float (+ (- secs +unix-epoch+)
(int32->subsecs subsec-int32))))))
(defun microseconds->subsecs (usecs)
(declare (type (integer 0 1000000) usecs))

239
osc.lisp
View file

@ -2,33 +2,33 @@
;;;
;;; an implementation of the OSC (Open Sound Control) protocol
;;;
;;; copyright (C) 2004 FoAM vzw.
;;; copyright (C) 2004 FoAM vzw.
;;;
;;; You are granted the rights to distribute and use this software
;;; under the terms of the Lisp Lesser GNU Public License, known
;;; as the LLGPL. The LLGPL consists of a preamble and the LGPL.
;;; under the terms of the Lisp Lesser GNU Public License, known
;;; as the LLGPL. The LLGPL consists of a preamble and the LGPL.
;;; Where these conflict, the preamble takes precedence. The LLGPL
;;; is available online at http://opensource.franz.com/preamble.html
;;; is available online at http://opensource.franz.com/preamble.html
;;; and is distributed with this code (see: LICENCE and LGPL files)
;;;
;;; authors
;;; authors
;;;
;;; nik gaffney <nik@f0.am>
;;;
;;; requirements
;;;
;;; dependent on sbcl, cmucl or openmcl for float encoding, other suggestions
;;; welcome.
;;; welcome.
;;;
;;; commentary
;;;
;;; this is a partial implementation of the OSC protocol which is used
;;; for communication mostly amongst music programs and their attatched
;;; musicians. eg. sc3, max/pd, reaktor/traktorska etc+. more details
;;; of the protocol can be found at the open sound control pages -=>
;;; musicians. eg. sc3, max/pd, reaktor/traktorska etc+. more details
;;; of the protocol can be found at the open sound control pages -=>
;;; http://www.cnmat.berkeley.edu/OpenSoundControl/
;;;
;;; - doesnt send nested bundles or timetags later than 'now'
;;;
;;; - doesnt send nested bundles or timetags later than 'now'
;;; - malformed input -> exception
;;; - int32 en/de-coding based on code (c) Walter C. Pelissero
;;; - unknown types are sent as 'blobs' which may or may not be an issue
@ -41,11 +41,11 @@
;;;
(in-package :osc)
;(declaim (optimize (speed 3) (safety 1) (debug 3)))
;;;;;; ; ;; ; ; ; ; ; ; ;
;;
;;
;; eNcoding OSC messages
;;
;;;; ;; ;; ; ; ;; ; ; ; ;
@ -54,27 +54,27 @@
"will encode an osc message, or list of messages as a bundle
with an optional timetag (symbol or 64bit int).
doesnt handle nested bundles"
(cat '(35 98 117 110 100 108 101 0) ; #bundle
(cat '(35 98 117 110 100 108 101 0) ; #bundle
(if timetag
(encode-timetag timetag)
(encode-timetag :now))
(if (listp (car data))
(apply #'cat (mapcar #'encode-bundle-elt data))
(encode-bundle-elt 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)))
(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))
(encode-address address)
(encode-typetags data)
(encode-data data)))
(encode-address address)
(encode-typetags data)
(encode-data data)))
(defun encode-address (address)
(cat (map 'vector #'char-code address)
(cat (map 'vector #'char-code address)
(string-padding address)))
(defun encode-typetags (data)
@ -83,45 +83,45 @@
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
NOTE: currently handles the following tags
i => #(105) => int32
f => #(102) => float
s => #(115) => string
s => #(115) => string
b => #(98) => blob
and considers non int/float/string data to be a blob."
and considers non int/float/string data to be a blob."
(let ((lump (make-array 0 :adjustable t
:fill-pointer t)))
(let ((lump (make-array 0 :adjustable t
:fill-pointer t)))
(macrolet ((write-to-vector (char)
`(vector-push-extend
(char-code ,char) lump)))
(write-to-vector #\,)
(dolist (x data)
(dolist (x data)
(typecase x
(integer (write-to-vector #\i))
(float (write-to-vector #\f))
(simple-string (write-to-vector #\s))
(keyword (write-to-vector #\s))
(t (write-to-vector #\b)))))
(keyword (write-to-vector #\s))
(t (write-to-vector #\b)))))
(cat lump
(pad (padding-length (length lump))))))
(pad (padding-length (length lump))))))
(defun encode-data (data)
"encodes data in a format suitable for an OSC message"
(let ((lump (make-array 0 :adjustable t :fill-pointer t)))
(macrolet ((enc (f)
`(setf lump (cat lump (,f x)))))
(dolist (x data)
(dolist (x data)
(typecase x
(integer (enc encode-int32))
(float (enc encode-float32))
(integer (enc encode-int32))
(float (enc encode-float32))
(simple-string (enc encode-string))
(t (enc encode-blob))))
(t (enc encode-blob))))
lump)))
;;;;;; ; ;; ; ; ; ; ; ; ;
;;
;;
;; decoding OSC messages
;;
;;; ;; ;; ; ; ; ; ; ;
@ -135,80 +135,81 @@ reusing buffers, you are responsible for ensuring that the buffer does
not contain stale data."
(unless bundle-length
(setf bundle-length (length data)))
;; (print (subseq data 0 bundle-length))
(let ((contents '()))
(if (equalp 35 (elt data 0)) ; a bundle begins with
; '#bundle' (8 bytes)
(let ((timetag (subseq data 8 16)) ; bytes 8-15 are timestamp
(i 16))
(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))))
(values (car contents) (decode-timetag timetag)))
(values (decode-message data) nil))))
(if (equalp 35 (elt data 0)) ; a bundle begins with
; '#bundle' (8 bytes)
(let ((timetag (subseq data 8 16)) ; bytes 8-15 are timestamp
(i 16))
(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))))
(values (car contents) (decode-timetag timetag)))
(values (decode-message data) nil))))
(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)
(if (eq x nil)
(format t "message contains no data.. ")
(cons (decode-address (subseq message 0 x))
(decode-taged-data (subseq message x))))))
(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))
(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
NOTE: currently handles the following tags
i => #(105) => int32
f => #(102) => float
s => #(115) => string
b => #(98) => blob"
(let ((div (position 0 data)))
(let ((tags (subseq data 1 div))
(acc (subseq data (padded-length div)))
(result '()))
(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)))
(end (padded-length (+ 4 size))))
(push (decode-blob (subseq acc 0 end))
result)
(setf acc (subseq acc end))))
(t (error "unrecognised typetag"))))
tags)
#'(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)))
(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
;;
;; - timetags can be encoded using a value, or the :now and :time
@ -222,7 +223,7 @@ not contain stale data."
;; - In SBCL, using sb-ext:get-time-of-day to get accurate seconds and
;; microseconds from OS.
;;
;;;; ;; ; ;
;;;; ;; ; ;
(defun encode-timetag (timetag)
"From the spec: `Time tags are represented by a 64 bit fixed point
@ -240,7 +241,7 @@ with the current time use (encode-timetag :time)."
;; encode timetag with current real time
(encode-int64 (get-current-timetag)))
((timetagp timetag)
;; encode osc timetag
;; encode osc timetag
(encode-int64 timetag))
(t (error "Argument given is not one of :now, :time, or timetagp."))))
@ -258,7 +259,7 @@ with the current time use (encode-timetag :time)."
;;; ;; ; ; ;
;; floats are encoded using implementation specific 'internals' which is not
;; particulaly portable, but 'works for now'.
;; particulaly portable, but 'works for now'.
(defun encode-float32 (f)
"encode an ieee754 float as a 4 byte vector. currently sbcl/cmucl specifc"
@ -266,7 +267,7 @@ with the current time use (encode-timetag :time)."
#+cmucl (encode-int32 (kernel:single-float-bits f))
#+openmcl (encode-int32 (CCL::SINGLE-FLOAT-BITS f))
#+allegro (encode-int32 (multiple-value-bind (x y) (excl:single-float-to-shorts f)
(+ (ash x 16) y)))
(+ (ash x 16) y)))
#-(or sbcl cmucl openmcl allegro) (error "cant encode floats using this implementation"))
(defun decode-float32 (s)
@ -275,17 +276,17 @@ with the current time use (encode-timetag :time)."
#+cmucl (kernel:make-single-float (decode-int32 s))
#+openmcl (CCL::HOST-SINGLE-FLOAT-FROM-UNSIGNED-BYTE-32 (decode-uint32 s))
#+allegro (excl:shorts-to-single-float (ldb (byte 16 16) (decode-int32 s))
(ldb (byte 16 0) (decode-int32 s)))
(ldb (byte 16 0) (decode-int32 s)))
#-(or sbcl cmucl openmcl allegro) (error "cant decode floats using this implementation"))
(defun encode-int32 (i)
"convert an integer into a sequence of 4 bytes in network byte order."
(declare (type integer i))
(let ((buf (make-sequence
'(vector (unsigned-byte 8)) 4)))
'(vector (unsigned-byte 8)) 4)))
(macrolet ((set-byte (n)
`(setf (elt buf ,n)
(logand #xff (ash i ,(* 8 (- n 3)))))))
`(setf (elt buf ,n)
(logand #xff (ash i ,(* 8 (- n 3)))))))
(set-byte 0)
(set-byte 1)
(set-byte 2)
@ -295,29 +296,29 @@ with the current time use (encode-timetag :time)."
(defun decode-int32 (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)
(ash (elt s 2) 8)
(elt s 3))))
(ash (elt s 1) 16)
(ash (elt s 2) 8)
(elt s 3))))
(if (>= i #x7fffffff)
(- 0 (- #x100000000 i))
i)))
i)))
(defun decode-uint32 (s)
"4 byte -> 32 bit unsigned int"
(let ((i (+ (ash (elt s 0) 24)
(ash (elt s 1) 16)
(ash (elt s 2) 8)
(elt s 3))))
(ash (elt s 1) 16)
(ash (elt s 2) 8)
(elt s 3))))
i))
(defun encode-int64 (i)
"convert an integer into a sequence of 8 bytes in network byte order."
(declare (type integer i))
(let ((buf (make-sequence
'(vector (unsigned-byte 8)) 8)))
'(vector (unsigned-byte 8)) 8)))
(macrolet ((set-byte (n)
`(setf (elt buf ,n)
(logand #xff (ash i ,(* 8 (- n 7)))))))
`(setf (elt buf ,n)
(logand #xff (ash i ,(* 8 (- n 7)))))))
(set-byte 0)
(set-byte 1)
(set-byte 2)
@ -331,20 +332,20 @@ with the current time use (encode-timetag :time)."
(defun decode-uint64 (s)
"8 byte -> 64 bit unsigned int"
(let ((i (+ (ash (elt s 0) 56)
(ash (elt s 1) 48)
(ash (elt s 2) 40)
(ash (elt s 3) 32)
(ash (elt s 4) 24)
(ash (elt s 5) 16)
(ash (elt s 6) 8)
(elt s 7))))
(ash (elt s 1) 48)
(ash (elt s 2) 40)
(ash (elt s 3) 32)
(ash (elt s 4) 24)
(ash (elt s 5) 16)
(ash (elt s 6) 8)
(elt s 7))))
i))
;; osc-strings are unsigned bytes, padded to a 4 byte boundary
;; osc-strings are unsigned bytes, padded to a 4 byte boundary
(defun encode-string (string)
"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)
(string-padding string)))
(defun decode-string (data)
@ -358,13 +359,13 @@ with the current time use (encode-timetag :time)."
"encodes a blob from a given vector"
(let ((bl (length blob)))
(cat (encode-int32 bl) blob
(pad (padding-length bl)))))
(pad (padding-length bl)))))
(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))))
(subseq blob 0 4))))
(subseq blob 4 (+ 4 size))))
;; utility functions for osc-string/padding slonking
@ -383,7 +384,7 @@ with the current time use (encode-timetag :time)."
(defun string-padding (string)
"returns the padding required for a given osc string"
(declare (type simple-string string))
(declare (type simple-string string))
(pad (padding-length (length string))))
(defun pad (n)

122
package.lisp
View file

@ -2,66 +2,66 @@
(:use :cl :sb-bsd-sockets)
(:documentation "OSC aka the 'open sound control' protocol")
(:export #:encode-message
#:encode-bundle
#:decode-message
#:decode-bundle
#:make-osc-tree
#:dp-register
#:dp-remove
#:dp-match
#:dispatch
#:encode-bundle
#:decode-message
#:decode-bundle
#:make-osc-tree
#:dp-register
#:dp-remove
#:dp-match
#:dispatch
#:get-current-timetag ; osc-time
#:timetag+
#:get-unix-time
#:unix-time->timetag
#:timetag->unix-time
#:print-as-double
#:get-current-timetag ; osc-time
#:timetag+
#:get-unix-time
#:unix-time->timetag
#:timetag->unix-time
#:print-as-double
#:osc-transmitter ; osc-devices
#:osc-transmitter-udp
#:osc-client
#:osc-client-udp
#:osc-client-tcp
#:osc-server
#:osc-server-udp
#:osc-server-tcp
#:protocol
#:name
#:buffer-size
#:quit
#:osc-device-cleanup
#:make-listening-thread ; listening
#:add-osc-responder ; dispatching
#:remove-osc-responder
#:make-osc-transmitter ; transmitters
#:connect
#:send
#:send-bundle
#:send-to
#:send-bundle-to
#:send-all
#:send-bundle-all
#:make-osc-client ; clients
#:make-client-responders
#:register
#:make-osc-server ; servers
#:boot
#:make-server-responders
#:register-udp-client
#:unregister-udp-client
#:register-tcp-client
#:unregister-tcp-client
#:post-register-hook
#:get-tcp-client
#:print-clients
#:send-to-client
#:send-bundle-to-client
#:*default-osc-buffer-size* ; socket stuff
#:make-name-string
#:device-active-p
#:device-socket-name
#:address
#:port
#:peer-address
#:peer-port))
#:osc-transmitter ; osc-devices
#:osc-transmitter-udp
#:osc-client
#:osc-client-udp
#:osc-client-tcp
#:osc-server
#:osc-server-udp
#:osc-server-tcp
#:protocol
#:name
#:buffer-size
#:quit
#:osc-device-cleanup
#:make-listening-thread ; listening
#:add-osc-responder ; dispatching
#:remove-osc-responder
#:make-osc-transmitter ; transmitters
#:connect
#:send
#:send-bundle
#:send-to
#:send-bundle-to
#:send-all
#:send-bundle-all
#:make-osc-client ; clients
#:make-client-responders
#:register
#:make-osc-server ; servers
#:boot
#:make-server-responders
#:register-udp-client
#:unregister-udp-client
#:register-tcp-client
#:unregister-tcp-client
#:post-register-hook
#:get-tcp-client
#:print-clients
#:send-to-client
#:send-bundle-to-client
#:*default-osc-buffer-size* ; sockets
#:make-name-string
#:device-active-p
#:device-socket-name
#:address
#:port
#:peer-address
#:peer-port))