From 9fe4513df571259101572ae07acde1dd9f5698f2 Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Sun, 14 Mar 2010 16:54:47 +0000 Subject: [PATCH 01/27] add optional buffer-length to decode-bundle Ignore-this: 81b0d2e19b287a2ee0b335be9bc0ec4e darcs-hash:20100314165447-16a00-c453301fefca88843434b78fec07ba04fcfb6910 --- osc.lisp | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/osc.lisp b/osc.lisp index cf7cab5..8d89761 100644 --- a/osc.lisp +++ b/osc.lisp @@ -133,14 +133,19 @@ ;; ;;; ;; ;; ; ; ; ; ; ; -(defun decode-bundle (data) - "decodes an osc bundle into a list of decoded-messages, which has - an osc-timetagas its first element" +(defun decode-bundle (data &optional bundle-length) + "Decodes an osc bundle into a list of decoded-messages, which has an +osc-timetagas its first element. An optional buffer-length argument +can be supplied (i.e. the length value returned by socket-receive), +otherwise the entire buffer is decoded - in which case, if you are +reusing buffers, you are responsible for ensuring that the buffer does +not contain stale data." + (unless bundle-length + (setf bundle-length (length data))) (let ((contents '())) (if (equalp 35 (elt data 0)) ; a bundle begins with '#' (let ((timetag (subseq data 8 16)) - (i 16) - (bundle-length (length data))) + (i 16)) (loop while (< i bundle-length) do (let ((mark (+ i 4)) (size (decode-int32 -- 2.39.5 From d269de398c1aaecf591fe76f3ee909f7edd861d9 Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Sun, 22 Aug 2010 19:24:55 +0100 Subject: [PATCH 02/27] twiddle some comments Ignore-this: 68a4da75a4298e67a0169d48e6163d7 darcs-hash:20100822182455-16a00-bf5db9f50cf1d3131862e2140d8481dcbf650679 --- osc.lisp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/osc.lisp b/osc.lisp index 8d89761..3c3743d 100644 --- a/osc.lisp +++ b/osc.lisp @@ -135,7 +135,7 @@ (defun decode-bundle (data &optional bundle-length) "Decodes an osc bundle into a list of decoded-messages, which has an -osc-timetagas its first element. An optional buffer-length argument +osc-timetag as its first element. An optional buffer-length argument can be supplied (i.e. the length value returned by socket-receive), otherwise the entire buffer is decoded - in which case, if you are reusing buffers, you are responsible for ensuring that the buffer does @@ -143,8 +143,9 @@ not contain stale data." (unless bundle-length (setf bundle-length (length data))) (let ((contents '())) - (if (equalp 35 (elt data 0)) ; a bundle begins with '#' - (let ((timetag (subseq data 8 16)) + (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)) -- 2.39.5 From f57144e330c2071b15b1d8de56a0e7395e419750 Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Sun, 22 Aug 2010 19:50:09 +0100 Subject: [PATCH 03/27] return multiple values from decode-bundle Ignore-this: 20df49a8bc026056062c4c762e4569f5 darcs-hash:20100822185009-16a00-45bf80a2cb04f64f246f49e25c2245ba8bb7b9e1 --- osc.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/osc.lisp b/osc.lisp index 3c3743d..6afcb31 100644 --- a/osc.lisp +++ b/osc.lisp @@ -157,8 +157,8 @@ not contain stale data." (subseq data mark (+ mark size))) contents)) (incf i (+ 4 size)))) - (push timetag contents)) - (decode-message data)))) + (values (car contents) (decode-timetag timetag))) + (values (decode-message data) nil)))) (defun decode-message (message) "reduces an osc message to an (address . data) pair. .." -- 2.39.5 From 819de36f0fd767c90574583b99ac51e36044d981 Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Wed, 15 Sep 2010 20:24:05 +0100 Subject: [PATCH 04/27] add new file osc-time providing timetag functionality Ignore-this: 6a3ef01b7b9ce62eb175d015bf3c8698 darcs-hash:20100915192405-16a00-78346f2b279308f4f3e76779437b7a55bf1d177a --- osc-time.lisp | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 75 insertions(+) create mode 100644 osc-time.lisp diff --git a/osc-time.lisp b/osc-time.lisp new file mode 100644 index 0000000..27c6dcd --- /dev/null +++ b/osc-time.lisp @@ -0,0 +1,75 @@ +(in-package #:osc) + +(defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) +(defconstant +2^32+ (expt 2 32)) +(defconstant +2^32/million+ (/ +2^32+ (expt 10 6))) +(defconstant +usecs+ (expt 10 6)) + +(deftype timetag () '(unsigned-byte 64)) + +(defun timetagp (object) + (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))))) + +(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." + (multiple-value-bind (secs usecs) + (sb-ext:get-time-of-day) + (the timetag (unix-secs+usecs->timetag secs usecs)))) + +(defun timetag+ (original seconds-offset) + (declare (type timetag original)) + (let ((offset (round (* seconds-offset +2^32+)))) + (the timetag (+ original offset)))) + + +;;;===================================================================== +;;; Functions for using double-float unix timestamps. +;;;===================================================================== + +(defun get-unix-time () + "Returns a a double-float representing real-time now in seconds, +with microsecond precision, relative to 19700101." + (multiple-value-bind (secs usecs) + (sb-ext:get-time-of-day) + (the double-float (+ secs (microseconds->subsecs usecs))))) + +(defun unix-time->timetag (unix-time) + (multiple-value-bind (secs subsecs) + (floor unix-time) + (the timetag + (unix-secs+usecs->timetag secs + (subsecs->microseconds subsecs))))) + +(defun timetag->unix-time (timetag) + (let* ((secs (ash timetag -32)) + (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)) + (coerce (/ usecs +usecs+) 'double-float)) + +(defun subsecs->microseconds (subsecs) + (declare (type (float 0 1) subsecs)) + (round (* subsecs +usecs+))) + +(defun int32->subsecs (int32) + "This maps a 32 bit integer, representing subsecond time, to a +double float in the range 0-1." + (declare (type (unsigned-byte 32) int32)) + (coerce (/ int32 +2^32+) 'double-float)) + +(defun print-as-double (time) + (format t "~%~F" (coerce time 'double-float)) + time) -- 2.39.5 From c739b3eca04802593d00166b5d3aa60d275443b0 Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Wed, 15 Sep 2010 20:35:12 +0100 Subject: [PATCH 05/27] change #'cat to return (unsigned-byte 8) vectors Ignore-this: 7e329f1ce1d3d108be83c6d3ea2bd5 darcs-hash:20100915193512-16a00-d86150e25298ac7ee175727ea6146ee47f030246 --- osc.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/osc.lisp b/osc.lisp index 6afcb31..d651cb1 100644 --- a/osc.lisp +++ b/osc.lisp @@ -351,7 +351,7 @@ not contain stale data." ;; utility functions for osc-string/padding slonking (defun cat (&rest catatac) - (apply #'concatenate '(vector *) catatac)) + (apply #'concatenate '(vector (unsigned-byte 8)) catatac)) (defun padding-length (s) "returns the length of padding required for a given length of string" -- 2.39.5 From 3ef5a50d7a8c43accd79311cbac1ff76e42bbd11 Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Sat, 25 Sep 2010 14:31:04 +0100 Subject: [PATCH 06/27] integrate new timetag implementation Ignore-this: 52c88aaef2bbd2921a90d4f423c89c7e Also update .asd and add a new package definition file. darcs-hash:20100925133104-16a00-69352e864aefbb59e43ce4e62a32f8ebd5d1810e --- osc-time.lisp | 10 ++-- osc.asd | 9 ++-- osc.lisp | 139 ++++++++++++++++++++++++++++---------------------- package.lisp | 19 +++++++ 4 files changed, 109 insertions(+), 68 deletions(-) create mode 100644 package.lisp diff --git a/osc-time.lisp b/osc-time.lisp index 27c6dcd..27609f7 100644 --- a/osc-time.lisp +++ b/osc-time.lisp @@ -51,10 +51,12 @@ with microsecond precision, relative to 19700101." (subsecs->microseconds subsecs))))) (defun timetag->unix-time (timetag) - (let* ((secs (ash timetag -32)) - (subsec-int32 (- timetag (ash secs 32)))) - (the double-float (+ (- secs +unix-epoch+) - (int32->subsecs subsec-int32))))) + (if (= timetag 1) + 1 ; immediate timetag + (let* ((secs (ash timetag -32)) + (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)) diff --git a/osc.asd b/osc.asd index 5c187aa..3016ce7 100644 --- a/osc.asd +++ b/osc.asd @@ -1,11 +1,14 @@ ;; -*- mode: lisp -*- -(in-package #:asdf) +(in-package #:common-lisp-user) -(defsystem osc +(asdf:defsystem osc :name "osc" :author "nik gaffney " :licence "LLGPL" :description "The Open Sound Control protocol, aka OSC" :version "0.5" - :components ((:file "osc"))) + :components ((:file "osc" :depends-on ("osc-time")) + (:file "osc-dispatch" :depends-on ("osc")) + (:file "osc-time" :depends-on ("package")) + (:file "package"))) diff --git a/osc.lisp b/osc.lisp index d651cb1..41e07b1 100644 --- a/osc.lisp +++ b/osc.lisp @@ -40,14 +40,6 @@ ;;; an error ;;; -(defpackage :osc - (:use :cl) - (:documentation "OSC aka the 'open sound control' protocol") - (:export :encode-message - :encode-bundle - :decode-message - :decode-bundle)) - (in-package :osc) ;(declaim (optimize (speed 3) (safety 1) (debug 3))) @@ -112,7 +104,7 @@ (t (write-to-vector #\b))))) (cat 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))) @@ -126,7 +118,7 @@ (t (enc encode-blob)))) lump))) - + ;;;;;; ; ;; ; ; ; ; ; ; ; ;; ;; decoding OSC messages @@ -218,50 +210,45 @@ not contain stale data." ;; ;; timetags ;; -;; - timetags can be encoded using a value, or the :now and :time keywords. the -;; keywords enable either a tag indicating 'immediate' execution, or -;; a tag containing the current time (which will most likely be in the past -;; of anyt receiver) to be created. -;; -;; - note: not well tested, and probably not accurate enough for syncronisation. -;; see also: CLHS 25.1.4 Time, and the ntp timestamp format. also needs to -;; convert from 2 32bit ints to 64bit fixed point value. +;; - timetags can be encoded using a value, or the :now and :time +;; keywords. the keywords enable either a tag indicating 'immediate' +;; execution, or a tag containing the current time (which will most +;; likely be in the past of any receiver) to be created. ;; ;; - see this c.l.l thread to sync universal-time and internal-time ;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/c207fef63a78d720/adc7442d2e4de5a0?lnk=gst&q=internal-real-time-sync&rnum=1#adc7442d2e4de5a0 + +;; - In SBCL, using sb-ext:get-time-of-day to get accurate seconds and +;; microseconds from OS. ;; ;;;; ;; ; ; -(defconstant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)) - -(defun encode-timetag (utime &optional subseconds) - "encodes an osc timetag from a universal-time and 32bit 'sub-second' part. - for an 'instantaneous' timetag use (encode-timetag :now) - for a timetag with the current time use (encode-timetag :time)" +(defun encode-timetag (timetag) + "From the spec: `Time tags are represented by a 64 bit fixed point +number. The first 32 bits specify the number of seconds since midnight +on January 1, 1900, and the last 32 bits specify fractional parts of a +second to a precision of about 200 picoseconds. This is the +representation used by Internet NTP timestamps'. For an +'instantaneous' timetag use (encode-timetag :now), and for a timetag +with the current time use (encode-timetag :time)." (cond - ;; a 1bit timetag will be interpreted as 'imediately' - ((equalp utime :now) - #(0 0 0 0 0 0 0 1)) - ;; converts seconds since 19000101 to seconds since 19700101 - ;; note: fractions of a second is accurate, but not syncronised. - ((equalp utime :time) - (cat (encode-int32 (- (get-universal-time) +unix-epoch+)) - (encode-int32 - (round (* internal-time-units-per-second - (second (multiple-value-list - (floor (/ (get-internal-real-time) - internal-time-units-per-second))))))))) - ((integerp utime) - (cat (encode-int32 (+ utime +unix-epoch+)) - (encode-int32 subseconds))) - (t (error "the time or subsecond given is not an integer")))) + ((equalp timetag :now) + ;; a 1 bit timetag will be interpreted as 'immediately' + #(0 0 0 0 0 0 0 1)) + ((equalp timetag :time) + ;; encode timetag with current real time + (encode-int64 (get-current-timetag))) + ((timetagp timetag) + ;; encode osc timetag + (encode-int64 timetag)) + (t (error "Argument given is not one of :now, :time, or timetagp.")))) (defun decode-timetag (timetag) - "decomposes a timetag into unix-time and a subsecond,. . ." - (list - (decode-int32 (subseq timetag 0 4)) - (decode-int32 (subseq timetag 4 8)))) - + "Return a 64 bit timetag from a vector of 8 bytes in network byte + order." + (if (equalp timetag #(0 0 0 0 0 0 0 1)) + 1 ; A timetag of 1 is defined as immediately. + (decode-uint64 timetag))) ;;;;; ; ; ;; ;; ; ; ;; @@ -290,6 +277,20 @@ not contain stale data." (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))) + (macrolet ((set-byte (n) + `(setf (elt buf ,n) + (logand #xff (ash i ,(* 8 (- n 3))))))) + (set-byte 0) + (set-byte 1) + (set-byte 2) + (set-byte 3)) + buf)) + (defun decode-int32 (s) "4 byte -> 32 bit int -> two's compliment (in network byte order)" (let ((i (+ (ash (elt s 0) 24) @@ -308,46 +309,62 @@ not contain stale data." (elt s 3)))) i)) -(defun encode-int32 (i) - "convert an integer into a sequence of 4 bytes in network byte order." +(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)) 4))) + (let ((buf (make-sequence + '(vector (unsigned-byte 8)) 8))) (macrolet ((set-byte (n) `(setf (elt buf ,n) - (logand #xff (ash i ,(* 8 (- n 3))))))) + (logand #xff (ash i ,(* 8 (- n 7))))))) (set-byte 0) (set-byte 1) (set-byte 2) - (set-byte 3)) + (set-byte 3) + (set-byte 4) + (set-byte 5) + (set-byte 6) + (set-byte 7)) buf)) -;; osc-strings are unsigned bytes, padded to a 4 byte boundary +(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)))) + i)) -(defun decode-string (data) - "converts a binary vector to a string and removes trailing #\nul characters" - (string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string))) +;; 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) (string-padding string))) +(defun decode-string (data) + "converts a binary vector to a string and removes trailing #\nul characters" + (string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string))) + ;; blobs are binary data, consisting of a length (int32) and bytes which are ;; osc-padded to a 4 byte boundary. -(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))))) +(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)))) + ;; utility functions for osc-string/padding slonking (defun cat (&rest catatac) diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..0b05524 --- /dev/null +++ b/package.lisp @@ -0,0 +1,19 @@ +(defpackage :osc + (: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 + + #:get-current-timetag ; osc-time + #:timetag+ + #:get-unix-time + #:unix-time->timetag + #:timetag->unix-time + #:print-as-double)) -- 2.39.5 From 05d6d6a27bea1a664c50052bfd7e7039b9e303b7 Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Sat, 25 Sep 2010 14:48:08 +0100 Subject: [PATCH 07/27] add osc-devices Ignore-this: 56da01e981b760cfc49a3007a67d629 darcs-hash:20100925134808-16a00-b2f8d2cd283140d964d264bec00e3ed67421bcae --- devices/client.lisp | 86 +++++++ devices/device.lisp | 126 +++++++++++ devices/dispatching-device.lisp | 37 ++++ devices/examples/osc-device-examples.lisp | 259 ++++++++++++++++++++++ devices/listening-device.lisp | 26 +++ devices/server.lisp | 181 +++++++++++++++ devices/socket-functions.lisp | 73 ++++++ devices/transmitter.lisp | 125 +++++++++++ osc-dispatch.lisp | 7 +- osc.asd | 17 +- osc.lisp | 1 + package.lisp | 50 ++++- 12 files changed, 983 insertions(+), 5 deletions(-) create mode 100644 devices/client.lisp create mode 100644 devices/device.lisp create mode 100644 devices/dispatching-device.lisp create mode 100644 devices/examples/osc-device-examples.lisp create mode 100644 devices/listening-device.lisp create mode 100644 devices/server.lisp create mode 100644 devices/socket-functions.lisp create mode 100644 devices/transmitter.lisp diff --git a/devices/client.lisp b/devices/client.lisp new file mode 100644 index 0000000..5317ffb --- /dev/null +++ b/devices/client.lisp @@ -0,0 +1,86 @@ +(cl:in-package #:osc) + +(defun make-osc-client (&key(protocol :udp) debug-mode + (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)) + (: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)))) + +(defmethod initialize-instance :after ((client osc-client-udp) &key) + (make-client-responders client)) + +(defgeneric make-client-responders (server)) + +(defmethod make-client-responders ((client osc-client-udp)) + (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))) + (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)))) + +(defgeneric register (client) + (:method ((client osc-client-udp)) + (send client "/cl-osc/register" (port client)))) + +(defmethod osc-device-cleanup ((device osc-client-udp)) + (send device "/cl-osc/quit") + (call-next-method)) + +(defun make-osc-client-endpoint-tcp (socket debug-mode buffer-size + address-tree clients &optional + cleanup-fun) + (socket-make-stream socket + :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))) + (set-socket socket client) + (set-listening-thread (make-listening-thread client) client) + client)) + +(defmethod make-listening-thread ((receiver osc-client-tcp)) + "Creates a listening thread for tcp clients." + (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 + address port timetag)) + (dispatch (address-tree receiver) message receiver + address port timetag)))) + (osc-device-cleanup receiver))) + :name (format nil "osc-client-tcp-connection: ~A~%" + (name receiver)))) diff --git a/devices/device.lisp b/devices/device.lisp new file mode 100644 index 0000000..45c1a08 --- /dev/null +++ b/devices/device.lisp @@ -0,0 +1,126 @@ +(cl:in-package #:osc) + +;;;===================================================================== +;;; OSC device base class +;;;===================================================================== + +(defclass osc-device () + ((socket + :reader socket + :writer set-socket + :initform nil) + (debug-mode + :reader debug-mode + :writer set-debug-mode + :initarg :debug-mode) + (cleanup-fun + :reader cleanup-fun + :initarg :cleanup-fun + :initform nil))) + +;;;===================================================================== +;;; OSC device mixin classes +;;;===================================================================== + +(defclass udp-device (osc-device) ()) + +(defclass tcp-device (osc-device) ()) + +(defclass listening-device (osc-device) + ((listening-thread + :reader listening-thread + :writer set-listening-thread + :initform nil))) + +(defclass receiving-device (listening-device) + ((socket-buffer + :reader socket-buffer + :initarg :socket-buffer + :initform (make-socket-buffer)))) + +(defclass dispatching-device (listening-device) + ((address-tree + :reader address-tree + :initarg :address-tree + :initform (make-osc-tree)))) + +(defclass dispatching-device-udp (dispatching-device receiving-device + udp-device) ()) + + +;;;===================================================================== +;;; OSC device abstract classes +;;;===================================================================== + +(defclass osc-transmitter (osc-device) ()) + +(defclass osc-client (dispatching-device receiving-device + osc-transmitter) ()) + +(defclass osc-server (dispatching-device osc-transmitter) + ((buffer-size + :reader buffer-size + :initarg :buffer-size) + (clients + :reader clients + :initarg :clients + :initform (make-clients-hash)))) + +(defclass osc-client-endpoint (osc-client) + ((clients + :reader clients + :initarg :clients))) + + +;;;===================================================================== +;;; OSC device concrete classes +;;;===================================================================== + +(defclass osc-transmitter-udp (osc-transmitter udp-device) ()) + +(defclass osc-client-udp (osc-client dispatching-device-udp) ()) + +(defclass osc-client-tcp (osc-client tcp-device) ()) + +(defclass osc-server-udp (osc-server dispatching-device-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) ()) + + +;;;===================================================================== +;;; Device generic functions +;;;===================================================================== + +(defgeneric protocol (osc-device) + (:method ((osc-device udp-device)) + :udp) + (:method ((osc-device tcp-device)) + :tcp)) + +(defgeneric name (osc-device) + (:method ((osc-device osc-device)) + (concatenate 'string + (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))) + +(defgeneric quit (osc-device)) + +(defgeneric osc-device-cleanup (device) + (:method :before ((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))) + (when (socket osc-device) + (socket-close (socket osc-device)) + (set-socket nil osc-device)))) diff --git a/devices/dispatching-device.lisp b/devices/dispatching-device.lisp new file mode 100644 index 0000000..e23793e --- /dev/null +++ b/devices/dispatching-device.lisp @@ -0,0 +1,37 @@ +(cl:in-package #:osc) + +(defmethod make-listening-thread ((receiver dispatching-device-udp)) + "Creates a listening thread for udp devices (client and server)." + (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)))) + (osc-device-cleanup receiver))) + :name (format nil "osc-receiver-udp: ~A~%" (name receiver)))) + + +;;;===================================================================== +;;; OSC Responders +;;;===================================================================== + +(defmacro add-osc-responder (dispatcher cmd-name + (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))) + +(defgeneric remove-osc-responder (dispatcher address) + (:method ((dispatcher dispatching-device) address) + (dp-remove (address-tree dispatcher) address))) diff --git a/devices/examples/osc-device-examples.lisp b/devices/examples/osc-device-examples.lisp new file mode 100644 index 0000000..84468ab --- /dev/null +++ b/devices/examples/osc-device-examples.lisp @@ -0,0 +1,259 @@ +(cl:in-package #:osc) + +(asdf:oos 'asdf:load-op 'osc) + +;;;===================================================================== +;;; OSC UDP transmitter -> server +;;;===================================================================== + +(defparameter *osc-server* (make-osc-server :protocol :udp + :debug-mode t)) + +(boot *osc-server* 57127) + +(defparameter *osc-transmitter* (make-osc-transmitter + :debug-mode t)) + +(connect *osc-transmitter* 57127 :host-name "localhost") +(device-active-p *osc-transmitter*) +(device-socket-name *osc-transmitter*) +(address *osc-transmitter*) +(port *osc-transmitter*) +(device-socket-peername *osc-transmitter*) +(peer-address *osc-transmitter*) +(peer-port *osc-transmitter*) + +(send *osc-transmitter* "/bar" 1 2 9) + +(send-bundle *osc-transmitter* + :time ; current real time + "/foo" 1 2 3) + +(send-bundle *osc-transmitter* + :now ; immediately + "/foo" 1 2 3) + +(send-bundle *osc-transmitter* + (unix-time->timetag 1234567890.1234567d0) + "/foo" 1 2 3) + +(quit *osc-transmitter*) +(quit *osc-server*) + + +;;;===================================================================== +;;; OSC UDP client <-> server +;;;===================================================================== + +(defparameter *osc-server* (make-osc-server :protocol :udp + :debug-mode t)) + +(boot *osc-server* 57127) + +(defparameter *osc-client* (make-osc-client + :protocol :udp + :debug-mode t)) + +(connect *osc-client* 57127 :host-name "localhost") + +;; A UDP server can't know about a client unless it registers. +(print-clients *osc-server*) +(register *osc-client*) +(print-clients *osc-server*) +(quit *osc-client*) ; quit notifies the server +(print-clients *osc-server*) + +(connect *osc-client* 57127 :host-name "localhost") + +(send *osc-client* "/foo" 2 99) + +(send-bundle *osc-client* + (unix-time->timetag 1234567890.1234567d0) + "/foo" 1 2 3) + +(send-bundle *osc-client* :now "/foo" 1) + +(send-bundle *osc-client* :time "/foo" 1) + +;; Using the server as a transmitter. +(send-to *osc-server* (address *osc-client*) (port *osc-client*) + "/bar" 1 2 3) + +;; If a client is registered... +(send-to-client *osc-server* (make-name-string *osc-client*) + "/bar" 2 99) + +(register *osc-client*) + +(send-to-client *osc-server* (make-name-string *osc-client*) + "/bar" 2 99) + +(send-bundle-to-client *osc-server* + (make-name-string *osc-client*) + :time + "/bar" 2 99) + +(add-osc-responder *osc-server* "/echo-sum" + (cmd args device address port timetag) + (send-to device address port "/echo-answer" (apply #'+ args))) + +(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" + (cmd args device address port timetag) + (send-bundle-to device address port (timetag+ timetag 1) "/future")) + +(send-bundle *osc-client* (get-current-timetag) + "/timetag+1") + +;; Send a messages to all registered clients. +(send-all *osc-server* "/foo" 1 2 3) + +(send-bundle-all *osc-server* :now "/foo" 1 2 3) + +(quit *osc-client*) +(quit *osc-server*) + + +;;;===================================================================== +;;; OSC TCP client <-> server +;;;===================================================================== + +(defparameter *osc-server* (make-osc-server :protocol :tcp + :debug-mode t)) + +(boot *osc-server* 57127) + +(defparameter *osc-client* (make-osc-client + :protocol :tcp + :debug-mode t)) + +(connect *osc-client* 57127 :host-name "localhost") + +(device-active-p *osc-client*) +(device-socket-name *osc-client*) +(device-socket-peername *osc-client*) + +(send *osc-client* "/foo" 1 2 3) + +(send-to-client *osc-server* (make-name-string + *osc-client*) + "/foo" 1 2 3) + +(defparameter *osc-client2* (make-osc-client + :protocol :tcp + :debug-mode t)) + +(connect *osc-client2* 57127 + :host-address "127.0.0.1" + :port 57666) ; choose local port + +(device-socket-name *osc-client2*) + +(send *osc-client2* "/bar" 4 5 6 9) + +(print-clients *osc-server*) + +(add-osc-responder *osc-server* "/print-sum" + (cmd args device address port timetag) + (format t "Sum = ~A~%" (apply #'+ args))) + +(send *osc-client2* "/print-sum" 4 5 6 9) + +(add-osc-responder *osc-server* "/echo-sum" + (cmd args disp address port timetag) + (send disp cmd (apply #'+ args))) + +(send *osc-client2* "/echo-sum" 4 5 6 9) + +(send-all *osc-server* "/bar" 1 2 3) ; send to all peers + +(add-osc-responder *osc-server* "/echo-sum-all" + (cmd args disp address port timetag) + (send-all disp cmd (apply #'+ args))) + +; Send to all peers (excluding self). +(send *osc-client2* "/echo-sum-all" 1 2 3) + +(quit *osc-client*) +(quit *osc-client2*) +(quit *osc-server*) + + +;;;===================================================================== +;;; OSC UDP client <-> sclang +;;;===================================================================== + +(defparameter *osc-client* (make-osc-client + :protocol :udp + :debug-mode t)) + +(connect *osc-client* 57120 :host-name "localhost" :port 57127) +(address *osc-client*) +(port *osc-client*) +(peer-address *osc-client*) +(peer-port *osc-client*) + +;;--------------------------------------------------------------------- +;; run in sc +c=OSCresponder( + nil, + '/foo', + {|t,r,msg,addr| [t,r,msg,addr].postln}).add +;;--------------------------------------------------------------------- + +(send *osc-client* "/foo" 1 2 3) + +(send-bundle *osc-client* + (get-current-timetag) + "/foo" 3) + +(add-osc-responder *osc-client* "/echo-sum" + (cmd args disp addr port timetag) + (send disp cmd (apply #'+ args))) + +;;--------------------------------------------------------------------- +;; Send /echo-sum from sc, and lisp returns the sum. +n=NetAddr("localhost", 57127) + +e=OSCresponder( + nil, + '/echo-sum', + {|t,r,msg,addr| + [t,r,msg,addr].postln; + }).add + +n.sendMsg('/echo-sum', 1, 2, 3) // send numbers, lisp returns sum. +;;--------------------------------------------------------------------- + +(quit *osc-client*) + + +;;;===================================================================== +;;; OSC UDP client <-> scsynth +;;;===================================================================== + +(defparameter *osc-client* (make-osc-client + :protocol :udp + :debug-mode t)) + +(connect *osc-client* 57110 :host-name "localhost" :port 57127) + +(send *osc-client* "/s_new" "default" 1001 0 0 "freq" 500) + +(send *osc-client* "/n_free" 1001) + +(send-bundle *osc-client* + (timetag+ (get-current-timetag) 2) ; 2 secs later + "/s_new" "default" 1001 0 0 "freq" 500) + +(send *osc-client* "/n_free" 1001) + +(quit *osc-client*) ; Sends default /quit notification which scsynth + ; ignores. Ideally osc-client should be subclassed + ; to allow scsynth specific behaviour to be + ; implemented. diff --git a/devices/listening-device.lisp b/devices/listening-device.lisp new file mode 100644 index 0000000..19dae74 --- /dev/null +++ b/devices/listening-device.lisp @@ -0,0 +1,26 @@ +(cl:in-package #:osc) + +(defgeneric make-listening-thread (listening-device)) + +(defmethod connect progn ((listening-device listening-device) + 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)) + +(defmethod quit ((device listening-device)) + (sb-thread:terminate-thread (listening-thread device))) + +(defmethod osc-device-cleanup ((device listening-device)) + (set-listening-thread nil device) + (call-next-method)) + +(defmethod osc-device-cleanup ((device receiving-device)) + (fill (socket-buffer device) 0) + (call-next-method)) + +(defun print-osc-debug-msg (receiver message length address port + timetag) + (format t "~%~A~%received:~A~A ~A bytes from ~A ~A ~%timetag:~A~A~%unix-time:~A~F~%" + (name receiver) #\Tab message length address port #\Tab + timetag #\Tab (when timetag (timetag->unix-time timetag)))) diff --git a/devices/server.lisp b/devices/server.lisp new file mode 100644 index 0000000..84e5913 --- /dev/null +++ b/devices/server.lisp @@ -0,0 +1,181 @@ +(cl:in-package #:osc) + +(defun make-osc-server (&key (protocol :udp) debug-mode + (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)) + (:tcp (make-instance 'osc-server-tcp + :debug-mode debug-mode + :cleanup-fun cleanup-fun + :buffer-size buffer-size)))) + +(defgeneric boot (osc-server port)) + +(defmethod boot :around ((server osc-server) port) + (if (device-active-p server) + (warn "~%Server ~A already running" (machine-instance))) + (set-socket (make-socket (protocol server)) server) + (socket-bind (socket server) #(0 0 0 0) port) + (call-next-method) + (format t "~%Server ~A listening on port ~A~%" + (machine-instance) port)) + +(defmethod boot ((server osc-server-udp) port) + (declare (ignore port)) + "UDP server sockets are used for receiving and unconnected sending." + (set-listening-thread (make-listening-thread server) server)) + +(defmethod boot ((server osc-server-tcp) port) + (declare (ignore port)) + (set-listening-thread + (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))) + :name (format nil "osc-server-tcp: ~A" (name server))) + server) + server) + +(defmethod osc-device-cleanup ((device osc-server-udp)) + (loop for client-name being the hash-key in (clients device) + using (hash-value addr+port) + do (notify-quit device client-name) + do (unregister-udp-client device + (first addr+port) + (second addr+port))) + (call-next-method)) + +(defmethod osc-device-cleanup ((device osc-server-tcp)) + (loop for client being the hash-value in (clients device) + do (quit client)) + (call-next-method)) + +(defun make-clients-hash () + (make-hash-table :test 'equal)) + + +;;;===================================================================== +;;; UDP server functions +;;;===================================================================== + +(defmethod initialize-instance :after ((server osc-server-udp) &key) + (make-server-responders server)) + +(defgeneric make-server-responders (server)) + +(defmethod make-server-responders ((server osc-server-udp)) + (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. + (register-udp-client device address + (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))) + +(defun register-udp-client (server addr port) + (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)) + (post-register-hook server client-name))) + +(defun unregister-udp-client (server addr port) + (let ((client-name (make-addr+port-string addr port))) + (format t "Client quit: ~A~%" client-name) + (remhash client-name (clients server)))) + +(defgeneric post-register-hook (server client-name) + (:method ((server osc-server-udp) client-name) + (format t "Post-register hook for client: ~A~%" client-name) + (notify-registered server client-name))) + +(defun notify-registered (server client-name) + (send-to-client server client-name "/cl-osc/server/registered")) + +(defun notify-quit (server client-name) + (send-to-client server client-name "/cl-osc/server/quit")) + + +;;;===================================================================== +;;; TCP server functions +;;;===================================================================== + +(defun register-tcp-client (server transmitter) + (setf (gethash (make-peername-string (socket transmitter)) + (clients server)) + transmitter)) + +(defun unregister-tcp-client (server transmitter) + (remhash (make-peername-string (socket transmitter)) + (clients server))) + +(defun make-unregister-self-fun (server) + #'(lambda (client) + (unregister-tcp-client server client))) + +(defun get-tcp-client (server socket-peername) + (gethash socket-peername (clients server))) + +(defgeneric print-clients (server)) + +(defmethod print-clients ((server osc-server-udp)) + (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))))) + +(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))))) + +;;;===================================================================== +;;; Server sending functions +;;;===================================================================== + +(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))))) + +(defmethod send-to-client ((server osc-server-udp) client-name &rest + msg) + (apply #'send-to server (first client-name) (second client-name) + 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) + (: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))))) + +(defmethod send-bundle-to-client ((server osc-server-udp) client-name + timetag &rest msg) + (apply #'send-bundle-to server (first client-name) + (second client-name) timetag msg)) diff --git a/devices/socket-functions.lisp b/devices/socket-functions.lisp new file mode 100644 index 0000000..823d764 --- /dev/null +++ b/devices/socket-functions.lisp @@ -0,0 +1,73 @@ +(cl:in-package #:osc) + +(defparameter *default-osc-buffer-size* 1024) + +(defun make-socket-buffer (&optional (size *default-osc-buffer-size*)) + (make-sequence '(vector (unsigned-byte 8)) size)) + +(defun make-socket (protocol) + (ecase protocol + (:udp (make-udp-socket)) + (:tcp (make-tcp-socket)))) + +(defun make-tcp-socket () + (make-instance 'inet-socket :type :stream :protocol :tcp)) + +(defun make-udp-socket () + (make-instance 'inet-socket :type :datagram :protocol :udp)) + +(defun make-peername-string (socket) + (multiple-value-bind (addr port) + (socket-peername socket) + (make-addr+port-string addr port))) + +(defun make-name-string (osc-device) + (when (socket osc-device) + (multiple-value-bind (addr port) + (socket-name (socket osc-device)) + (make-addr+port-string addr port)))) + +(defun make-addr+port-string (addr port) + (format nil "~{~A~^.~}:~A" (coerce addr 'list) port)) + +(defun device-active-p (osc-device) + (when (socket osc-device) + (socket-open-p (socket osc-device)))) + +(defun device-socket-name (osc-device) + (socket-name (socket osc-device))) + +(defun port (osc-device) + (if (device-active-p osc-device) + (multiple-value-bind (addr port) + (device-socket-name osc-device) + (declare (ignore addr)) + port) + (warn "Device not connected."))) + +(defun address (osc-device) + (if (device-active-p osc-device) + (multiple-value-bind (addr port) + (device-socket-name osc-device) + (declare (ignore port)) + addr) + (warn "Device not connected."))) + +(defun device-socket-peername (osc-device) + (socket-peername (socket osc-device))) + +(defun peer-port (osc-device) + (if (device-active-p osc-device) + (multiple-value-bind (addr port) + (device-socket-peername osc-device) + (declare (ignore addr)) + port) + (warn "Device not connected."))) + +(defun peer-address (osc-device) + (if (device-active-p osc-device) + (multiple-value-bind (addr port) + (device-socket-peername osc-device) + (declare (ignore port)) + addr) + (warn "Device not connected."))) diff --git a/devices/transmitter.lisp b/devices/transmitter.lisp new file mode 100644 index 0000000..98d2a8c --- /dev/null +++ b/devices/transmitter.lisp @@ -0,0 +1,125 @@ +(cl:in-package #:osc) + +;; Only UDP devices can be transmitters. + +(defun make-osc-transmitter (&key debug-mode cleanup-fun) + (make-instance 'osc-transmitter-udp + :debug-mode debug-mode + :cleanup-fun cleanup-fun)) + +(defgeneric connect (osc-transmitter host-port &key host-address + 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) + (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))))) + (if (not (device-active-p transmitter)) + (progn + (let ((socket (make-socket (protocol transmitter)))) + (socket-bind socket #(127 0 0 1) port) + (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) + +(defmethod quit ((transmitter osc-transmitter-udp)) + (if (device-active-p transmitter) + (osc-device-cleanup transmitter) + (warn "Not connected: ~A" (name transmitter)))) + + +;;;===================================================================== +;;; Sending functions +;;;===================================================================== + +(defmacro osc-write-to-stream (stream &body msg) + `(progn (write-sequence ,@msg ,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)))) + +(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)))) + +;; Unconnected sending + +(defgeneric send-to (transmitter address port &rest msg-args) + (:method ((transmitter osc-transmitter-udp) address port &rest + msg-args) + (socket-send (socket transmitter) + (apply #'encode-message msg-args) nil + :address (list address port)))) + +(defgeneric send-bundle-to (transmitter address port timestamp &rest + msg-args) + (:method ((transmitter osc-transmitter-udp) address port timestamp + &rest msg-args) + (socket-send (socket transmitter) + (apply #'encode-bundle msg-args (list timestamp)) nil + :address (list address port)))) + +;; Server functions + +(defgeneric send-all (server &rest msg-args)) + +(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))) + +(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) + (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))) + +(defgeneric send-bundle-all (server timetag &rest msg-args)) + +(defmethod send-bundle-all ((server osc-server-udp) timetag &rest + 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))) + +(defmethod send-bundle-all ((server osc-server-tcp) timetag &rest + 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) + (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))) diff --git a/osc-dispatch.lisp b/osc-dispatch.lisp index afe293c..7fc706e 100644 --- a/osc-dispatch.lisp +++ b/osc-dispatch.lisp @@ -62,11 +62,12 @@ dispatch for a given address pattern.." (list (gethash pattern tree))) -(defun dispatch (tree osc-message) +(defun dispatch (tree osc-message &optional device address port + 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) - (apply #'x (cdr osc-message)))))) - + (funcall x (car osc-message) (cdr osc-message) device address + port timetag))))) diff --git a/osc.asd b/osc.asd index 3016ce7..9f8244e 100644 --- a/osc.asd +++ b/osc.asd @@ -11,4 +11,19 @@ :components ((:file "osc" :depends-on ("osc-time")) (:file "osc-dispatch" :depends-on ("osc")) (:file "osc-time" :depends-on ("package")) - (:file "package"))) + (:file "package") + (:module "devices" + :depends-on ("package") + ::components + ((:file "socket-functions") + (:file "device") + (:file "transmitter" + :depends-on ("device" + "socket-functions")) + (:file "listening-device" + :depends-on ("transmitter")) + (:file "dispatching-device" + :depends-on ("listening-device")) + (:file "client" + :depends-on ("dispatching-device")) + (:file "server" :depends-on ("client")))))) diff --git a/osc.lisp b/osc.lisp index 41e07b1..f06f77c 100644 --- a/osc.lisp +++ b/osc.lisp @@ -101,6 +101,7 @@ (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))))) (cat lump (pad (padding-length (length lump)))))) diff --git a/package.lisp b/package.lisp index 0b05524..d0b0b55 100644 --- a/package.lisp +++ b/package.lisp @@ -16,4 +16,52 @@ #:get-unix-time #:unix-time->timetag #:timetag->unix-time - #:print-as-double)) + #: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)) -- 2.39.5 From 73b2376168e9ac84694705354986f8beee088e3c Mon Sep 17 00:00:00 2001 From: "j.forth" Date: Mon, 6 Dec 2010 22:30:58 +0000 Subject: [PATCH 08/27] twiddle listener debug format Ignore-this: 5175799645ca7ee38cd96445de532e2c darcs-hash:20101206223058-16a00-df77e33c92f4343b147536ed8729209fa47844cb --- devices/listening-device.lisp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/devices/listening-device.lisp b/devices/listening-device.lisp index 19dae74..d710d95 100644 --- a/devices/listening-device.lisp +++ b/devices/listening-device.lisp @@ -21,6 +21,7 @@ (defun print-osc-debug-msg (receiver message length address port timetag) - (format t "~%~A~%received:~A~A ~A bytes from ~A ~A ~%timetag:~A~A~%unix-time:~A~F~%" - (name receiver) #\Tab message length address port #\Tab - timetag #\Tab (when timetag (timetag->unix-time 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)))) -- 2.39.5 From bbbc2c437b2f766f84748c8b557d8d69522c9c42 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Tue, 7 Jul 2015 17:08:14 +0100 Subject: [PATCH 09/27] change the devices example to load using quicklisp --- devices/examples/osc-device-examples.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/devices/examples/osc-device-examples.lisp b/devices/examples/osc-device-examples.lisp index 84468ab..63463d6 100644 --- a/devices/examples/osc-device-examples.lisp +++ b/devices/examples/osc-device-examples.lisp @@ -1,6 +1,6 @@ (cl:in-package #:osc) -(asdf:oos 'asdf:load-op 'osc) +(ql:quickload "osc") ;;;===================================================================== ;;; OSC UDP transmitter -> server -- 2.39.5 From 59c32ec6b585c9d0b797bc4bccc16cb9690e883d Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Tue, 7 Jul 2015 17:13:06 +0100 Subject: [PATCH 10/27] remove tab characters from device examples --- devices/examples/osc-device-examples.lisp | 99 +++++++++++------------ 1 file changed, 48 insertions(+), 51 deletions(-) diff --git a/devices/examples/osc-device-examples.lisp b/devices/examples/osc-device-examples.lisp index 63463d6..235b736 100644 --- a/devices/examples/osc-device-examples.lisp +++ b/devices/examples/osc-device-examples.lisp @@ -7,12 +7,12 @@ ;;;===================================================================== (defparameter *osc-server* (make-osc-server :protocol :udp - :debug-mode t)) + :debug-mode t)) (boot *osc-server* 57127) (defparameter *osc-transmitter* (make-osc-transmitter - :debug-mode t)) + :debug-mode t)) (connect *osc-transmitter* 57127 :host-name "localhost") (device-active-p *osc-transmitter*) @@ -26,16 +26,16 @@ (send *osc-transmitter* "/bar" 1 2 9) (send-bundle *osc-transmitter* - :time ; current real time - "/foo" 1 2 3) + :time ; current real time + "/foo" 1 2 3) (send-bundle *osc-transmitter* - :now ; immediately - "/foo" 1 2 3) + :now ; immediately + "/foo" 1 2 3) (send-bundle *osc-transmitter* - (unix-time->timetag 1234567890.1234567d0) - "/foo" 1 2 3) + (unix-time->timetag 1234567890.1234567d0) + "/foo" 1 2 3) (quit *osc-transmitter*) (quit *osc-server*) @@ -46,13 +46,13 @@ ;;;===================================================================== (defparameter *osc-server* (make-osc-server :protocol :udp - :debug-mode t)) + :debug-mode t)) (boot *osc-server* 57127) (defparameter *osc-client* (make-osc-client - :protocol :udp - :debug-mode t)) + :protocol :udp + :debug-mode t)) (connect *osc-client* 57127 :host-name "localhost") @@ -60,7 +60,7 @@ (print-clients *osc-server*) (register *osc-client*) (print-clients *osc-server*) -(quit *osc-client*) ; quit notifies the server +(quit *osc-client*) ; quit notifies the server (print-clients *osc-server*) (connect *osc-client* 57127 :host-name "localhost") @@ -68,8 +68,8 @@ (send *osc-client* "/foo" 2 99) (send-bundle *osc-client* - (unix-time->timetag 1234567890.1234567d0) - "/foo" 1 2 3) + (unix-time->timetag 1234567890.1234567d0) + "/foo" 1 2 3) (send-bundle *osc-client* :now "/foo" 1) @@ -77,21 +77,20 @@ ;; Using the server as a transmitter. (send-to *osc-server* (address *osc-client*) (port *osc-client*) - "/bar" 1 2 3) + "/bar" 1 2 3) ;; If a client is registered... (send-to-client *osc-server* (make-name-string *osc-client*) - "/bar" 2 99) + "/bar" 2 99) (register *osc-client*) (send-to-client *osc-server* (make-name-string *osc-client*) - "/bar" 2 99) + "/bar" 2 99) (send-bundle-to-client *osc-server* - (make-name-string *osc-client*) - :time - "/bar" 2 99) + (make-name-string *osc-client*) + :timeq "/bar" 2 99) (add-osc-responder *osc-server* "/echo-sum" (cmd args device address port timetag) @@ -108,7 +107,7 @@ (send-bundle-to device address port (timetag+ timetag 1) "/future")) (send-bundle *osc-client* (get-current-timetag) - "/timetag+1") + "/timetag+1") ;; Send a messages to all registered clients. (send-all *osc-server* "/foo" 1 2 3) @@ -124,13 +123,13 @@ ;;;===================================================================== (defparameter *osc-server* (make-osc-server :protocol :tcp - :debug-mode t)) + :debug-mode t)) (boot *osc-server* 57127) (defparameter *osc-client* (make-osc-client - :protocol :tcp - :debug-mode t)) + :protocol :tcp + :debug-mode t)) (connect *osc-client* 57127 :host-name "localhost") @@ -141,16 +140,16 @@ (send *osc-client* "/foo" 1 2 3) (send-to-client *osc-server* (make-name-string - *osc-client*) - "/foo" 1 2 3) + *osc-client*) + "/foo" 1 2 3) (defparameter *osc-client2* (make-osc-client - :protocol :tcp - :debug-mode t)) + :protocol :tcp + :debug-mode t)) (connect *osc-client2* 57127 - :host-address "127.0.0.1" - :port 57666) ; choose local port + :host-address "127.0.0.1" + :port 57666) ; choose local port (device-socket-name *osc-client2*) @@ -189,8 +188,8 @@ ;;;===================================================================== (defparameter *osc-client* (make-osc-client - :protocol :udp - :debug-mode t)) + :protocol :udp + :debug-mode t)) (connect *osc-client* 57120 :host-name "localhost" :port 57127) (address *osc-client*) @@ -200,17 +199,16 @@ ;;--------------------------------------------------------------------- ;; run in sc -c=OSCresponder( - nil, - '/foo', - {|t,r,msg,addr| [t,r,msg,addr].postln}).add +c=OSCresponder(nil, + '/foo', + {|t,r,msg,addr| [t,r,msg,addr].postln}).add ;;--------------------------------------------------------------------- (send *osc-client* "/foo" 1 2 3) (send-bundle *osc-client* - (get-current-timetag) - "/foo" 3) + (get-current-timetag) + "/foo" 3) (add-osc-responder *osc-client* "/echo-sum" (cmd args disp addr port timetag) @@ -220,12 +218,11 @@ c=OSCresponder( ;; Send /echo-sum from sc, and lisp returns the sum. n=NetAddr("localhost", 57127) -e=OSCresponder( - nil, - '/echo-sum', - {|t,r,msg,addr| - [t,r,msg,addr].postln; - }).add +e=OSCresponder(nil, + '/echo-sum', + {|t,r,msg,addr| + [t,r,msg,addr].postln; + }).add n.sendMsg('/echo-sum', 1, 2, 3) // send numbers, lisp returns sum. ;;--------------------------------------------------------------------- @@ -238,8 +235,8 @@ n.sendMsg('/echo-sum', 1, 2, 3) // send numbers, lisp returns sum. ;;;===================================================================== (defparameter *osc-client* (make-osc-client - :protocol :udp - :debug-mode t)) + :protocol :udp + :debug-mode t)) (connect *osc-client* 57110 :host-name "localhost" :port 57127) @@ -248,12 +245,12 @@ n.sendMsg('/echo-sum', 1, 2, 3) // send numbers, lisp returns sum. (send *osc-client* "/n_free" 1001) (send-bundle *osc-client* - (timetag+ (get-current-timetag) 2) ; 2 secs later - "/s_new" "default" 1001 0 0 "freq" 500) + (timetag+ (get-current-timetag) 2) ; 2 secs later + "/s_new" "default" 1001 0 0 "freq" 500) (send *osc-client* "/n_free" 1001) (quit *osc-client*) ; Sends default /quit notification which scsynth - ; ignores. Ideally osc-client should be subclassed - ; to allow scsynth specific behaviour to be - ; implemented. + ; ignores. Ideally osc-client should be subclassed + ; to allow scsynth specific behaviour to be + ; implemented. -- 2.39.5 From 95e8643778df10defb3d0033631779d827b4af38 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Tue, 7 Jul 2015 17:13:42 +0100 Subject: [PATCH 11/27] make sure nil is not passed to socket-bind now that sbcl type-checks the arguments --- devices/transmitter.lisp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/devices/transmitter.lisp b/devices/transmitter.lisp index 98d2a8c..80644ba 100644 --- a/devices/transmitter.lisp +++ b/devices/transmitter.lisp @@ -28,7 +28,9 @@ (if (not (device-active-p transmitter)) (progn (let ((socket (make-socket (protocol transmitter)))) - (socket-bind socket #(127 0 0 1) port) + (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 -- 2.39.5 From 0e4509bc75c328eb459e75f0ce0e482ba0e658af Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Tue, 7 Jul 2015 17:16:54 +0100 Subject: [PATCH 12/27] fix debug printing of peer address and port for tcp sockets --- devices/client.lisp | 3 ++- devices/dispatching-device.lisp | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/devices/client.lisp b/devices/client.lisp index 5317ffb..ac984b7 100644 --- a/devices/client.lisp +++ b/devices/client.lisp @@ -78,7 +78,8 @@ (decode-bundle buffer length) (when (debug-mode receiver) (print-osc-debug-msg receiver message length - address port timetag)) + (peer-address receiver) + (peer-port receiver) timetag)) (dispatch (address-tree receiver) message receiver address port timetag)))) (osc-device-cleanup receiver))) diff --git a/devices/dispatching-device.lisp b/devices/dispatching-device.lisp index e23793e..4b63f65 100644 --- a/devices/dispatching-device.lisp +++ b/devices/dispatching-device.lisp @@ -12,8 +12,8 @@ (multiple-value-bind (message timetag) (osc:decode-bundle buffer length) (when (debug-mode receiver) - (print-osc-debug-msg receiver message length - address port timetag)) + (print-osc-debug-msg receiver message length address + port timetag)) (osc:dispatch (address-tree receiver) message receiver address port timetag)))) (osc-device-cleanup receiver))) -- 2.39.5 From 7d43627bcc8ba03540632ca44482721c310753c4 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 10 Jul 2015 16:26:00 +0100 Subject: [PATCH 13/27] add simple-stream-error handler in osc-device-cleanup --- devices/device.lisp | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/devices/device.lisp b/devices/device.lisp index 45c1a08..81fc058 100644 --- a/devices/device.lisp +++ b/devices/device.lisp @@ -122,5 +122,9 @@ (format t "~%OSC device stopped: ~A~%" (name osc-device))) (when (socket osc-device) - (socket-close (socket osc-device)) + (handler-case + (socket-close (socket osc-device) :abort t) + (sb-int:simple-stream-error () + (when (debug-mode osc-device) + (warn "Device ~A gone away." (name osc-device))))) (set-socket nil osc-device)))) -- 2.39.5 From 3303d3b7de08b0a933c308e2f62594ffd634d935 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 10 Jul 2015 16:28:30 +0100 Subject: [PATCH 14/27] key client sockets on the server-side socket name, not the peername --- devices/server.lisp | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/devices/server.lisp b/devices/server.lisp index 84e5913..0fdcd95 100644 --- a/devices/server.lisp +++ b/devices/server.lisp @@ -117,13 +117,18 @@ ;;;===================================================================== (defun register-tcp-client (server transmitter) - (setf (gethash (make-peername-string (socket transmitter)) - (clients server)) - transmitter)) + "Clients are keyed on the names-string of the server-side socket, +not the peer name because the peer may close the socket after which +the peer name is no longer available. FIXME: Maybe we want to store +the peername independently of the socket's connection status?" + (let ((client-name (make-name-string transmitter))) + (when (debug-mode server) + (format t "Client registered: ~A~%" client-name)) + (setf (gethash client-name (clients server)) transmitter))) (defun unregister-tcp-client (server transmitter) - (remhash (make-peername-string (socket transmitter)) - (clients server))) + (remhash (make-name-string transmitter) + (clients server))) (defun make-unregister-self-fun (server) #'(lambda (client) -- 2.39.5 From 57a867f119e4d0f126f694866d2eebfa34af4630 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 10 Jul 2015 16:33:11 +0100 Subject: [PATCH 15/27] add handler-case in peer addr/port functions for not-connected-error --- devices/socket-functions.lisp | 46 +++++++++++++++++++++-------------- 1 file changed, 28 insertions(+), 18 deletions(-) diff --git a/devices/socket-functions.lisp b/devices/socket-functions.lisp index 823d764..7c0b92a 100644 --- a/devices/socket-functions.lisp +++ b/devices/socket-functions.lisp @@ -40,34 +40,44 @@ (defun port (osc-device) (if (device-active-p osc-device) (multiple-value-bind (addr port) - (device-socket-name osc-device) - (declare (ignore addr)) - port) - (warn "Device not connected."))) + (device-socket-name osc-device) + (declare (ignore addr)) + port) + (warn "Device not active."))) (defun address (osc-device) (if (device-active-p osc-device) (multiple-value-bind (addr port) - (device-socket-name osc-device) - (declare (ignore port)) - addr) - (warn "Device not connected."))) + (device-socket-name osc-device) + (declare (ignore port)) + addr) + (warn "Device not active."))) (defun device-socket-peername (osc-device) (socket-peername (socket osc-device))) (defun peer-port (osc-device) (if (device-active-p osc-device) - (multiple-value-bind (addr port) - (device-socket-peername osc-device) - (declare (ignore addr)) - port) - (warn "Device not connected."))) + (handler-case + (multiple-value-bind (addr port) + (device-socket-peername osc-device) + (declare (ignore addr)) + port) + (sb-bsd-sockets:not-connected-error () + (warn "Device ~a not connected: device removed." + (device-socket-name osc-device)) + (osc-device-cleanup osc-device))) + (warn "Device not active."))) (defun peer-address (osc-device) (if (device-active-p osc-device) - (multiple-value-bind (addr port) - (device-socket-peername osc-device) - (declare (ignore port)) - addr) - (warn "Device not connected."))) + (handler-case + (multiple-value-bind (addr port) + (device-socket-peername osc-device) + (declare (ignore port)) + addr) + (sb-bsd-sockets:not-connected-error () + (warn "Device ~a not connected: device removed." + (device-socket-name osc-device)) + (osc-device-cleanup osc-device))) + (warn "Device not active."))) -- 2.39.5 From 5568554056fe8287ea07fdc0c110de6ee4d0ac78 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 10 Jul 2015 16:33:56 +0100 Subject: [PATCH 16/27] change make-peername-string to accept a device not socket --- devices/socket-functions.lisp | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/devices/socket-functions.lisp b/devices/socket-functions.lisp index 7c0b92a..c522031 100644 --- a/devices/socket-functions.lisp +++ b/devices/socket-functions.lisp @@ -16,10 +16,11 @@ (defun make-udp-socket () (make-instance 'inet-socket :type :datagram :protocol :udp)) -(defun make-peername-string (socket) - (multiple-value-bind (addr port) - (socket-peername socket) - (make-addr+port-string addr port))) +(defun make-peername-string (osc-device) + (when (socket osc-device) + (multiple-value-bind (addr port) + (socket-peername (socket osc-device)) + (make-addr+port-string addr port)))) (defun make-name-string (osc-device) (when (socket osc-device) -- 2.39.5 From 03b078c20fb3039e1ffbe8adc57519c0a6c49887 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 10 Jul 2015 16:41:42 +0100 Subject: [PATCH 17/27] code reformat --- devices/client.lisp | 94 ++++----- devices/device.lisp | 22 +- devices/dispatching-device.lisp | 33 +-- devices/examples/osc-device-examples.lisp | 4 +- devices/listening-device.lisp | 12 +- devices/server.lisp | 84 ++++---- devices/socket-functions.lisp | 2 +- devices/transmitter.lisp | 88 ++++---- osc-dispatch.lisp | 10 +- osc-examples.lisp | 59 +++--- osc-time.lisp | 30 +-- osc.lisp | 239 +++++++++++----------- package.lisp | 122 +++++------ 13 files changed, 401 insertions(+), 398 deletions(-) diff --git a/devices/client.lisp b/devices/client.lisp index ac984b7..7374677 100644 --- a/devices/client.lisp +++ b/devices/client.lisp @@ -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)))) diff --git a/devices/device.lisp b/devices/device.lisp index 81fc058..40e75d6 100644 --- a/devices/device.lisp +++ b/devices/device.lisp @@ -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) diff --git a/devices/dispatching-device.lisp b/devices/dispatching-device.lisp index 4b63f65..b6e5198 100644 --- a/devices/dispatching-device.lisp +++ b/devices/dispatching-device.lisp @@ -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) diff --git a/devices/examples/osc-device-examples.lisp b/devices/examples/osc-device-examples.lisp index 235b736..9d13dea 100644 --- a/devices/examples/osc-device-examples.lisp +++ b/devices/examples/osc-device-examples.lisp @@ -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 diff --git a/devices/listening-device.lisp b/devices/listening-device.lisp index d710d95..9964abf 100644 --- a/devices/listening-device.lisp +++ b/devices/listening-device.lisp @@ -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)))) diff --git a/devices/server.lisp b/devices/server.lisp index 0fdcd95..d90cf4c 100644 --- a/devices/server.lisp +++ b/devices/server.lisp @@ -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)) diff --git a/devices/socket-functions.lisp b/devices/socket-functions.lisp index c522031..2505fa6 100644 --- a/devices/socket-functions.lisp +++ b/devices/socket-functions.lisp @@ -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) diff --git a/devices/transmitter.lisp b/devices/transmitter.lisp index 80644ba..a2a6bea 100644 --- a/devices/transmitter.lisp +++ b/devices/transmitter.lisp @@ -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))) diff --git a/osc-dispatch.lisp b/osc-dispatch.lisp index 7fc706e..99ff12c 100644 --- a/osc-dispatch.lisp +++ b/osc-dispatch.lisp @@ -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))))) diff --git a/osc-examples.lisp b/osc-examples.lisp index 80505b3..384b14b 100644 --- a/osc-examples.lisp +++ b/osc-examples.lisp @@ -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 diff --git a/osc-time.lisp b/osc-time.lisp index 27609f7..f334daf 100644 --- a/osc-time.lisp +++ b/osc-time.lisp @@ -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)) diff --git a/osc.lisp b/osc.lisp index f06f77c..5571842 100644 --- a/osc.lisp +++ b/osc.lisp @@ -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 ;;; ;;; 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) diff --git a/package.lisp b/package.lisp index d0b0b55..60a8db5 100644 --- a/package.lisp +++ b/package.lisp @@ -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)) -- 2.39.5 From 85d39627a0fc3499f424625a3b16dc49e039a9ca Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Thu, 20 Aug 2015 11:30:03 +0100 Subject: [PATCH 18/27] Revert "key client sockets on the server-side socket name, not the peername" This reverts commit 3303d3b7de08b0a933c308e2f62594ffd634d935. This was a bad idea as it prevents the server handling multiple clients from the same host. The better solution is to store the client's address and port in the client object rather than rely on the status of the client's socket. --- devices/server.lisp | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/devices/server.lisp b/devices/server.lisp index d90cf4c..c6014ee 100644 --- a/devices/server.lisp +++ b/devices/server.lisp @@ -117,18 +117,13 @@ ;;;===================================================================== (defun register-tcp-client (server transmitter) - "Clients are keyed on the names-string of the server-side socket, -not the peer name because the peer may close the socket after which -the peer name is no longer available. FIXME: Maybe we want to store -the peername independently of the socket's connection status?" - (let ((client-name (make-name-string transmitter))) - (when (debug-mode server) - (format t "Client registered: ~A~%" client-name)) - (setf (gethash client-name (clients server)) transmitter))) + (setf (gethash (make-peername-string transmitter) + (clients server)) + transmitter)) (defun unregister-tcp-client (server transmitter) - (remhash (make-name-string transmitter) - (clients server))) + (remhash (make-peername-string transmitter) + (clients server))) (defun make-unregister-self-fun (server) #'(lambda (client) -- 2.39.5 From 00c9020045ba2d7a5942cbce5acc3980d850e352 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 21 Aug 2015 15:23:55 +0100 Subject: [PATCH 19/27] fix bug where udp devices were ignoring :buffer-size --- devices/device.lisp | 3 +-- devices/server.lisp | 3 ++- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/devices/device.lisp b/devices/device.lisp index 40e75d6..980f50a 100644 --- a/devices/device.lisp +++ b/devices/device.lisp @@ -35,8 +35,7 @@ (defclass receiving-device (listening-device) ((socket-buffer :reader socket-buffer - :initarg :socket-buffer - :initform (make-socket-buffer)))) + :initarg :socket-buffer))) (defclass dispatching-device (listening-device) ((address-tree diff --git a/devices/server.lisp b/devices/server.lisp index c6014ee..df72d6f 100644 --- a/devices/server.lisp +++ b/devices/server.lisp @@ -7,7 +7,8 @@ (:udp (make-instance 'osc-server-udp :debug-mode debug-mode :cleanup-fun cleanup-fun - :buffer-size buffer-size)) + :buffer-size buffer-size + :socket-buffer (make-socket-buffer buffer-size))) (:tcp (make-instance 'osc-server-tcp :debug-mode debug-mode :cleanup-fun cleanup-fun -- 2.39.5 From f5a9fd80698044459c12ed0d710676aadbf4c169 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 21 Aug 2015 15:24:04 +0100 Subject: [PATCH 20/27] implement sending and receiving of nested bundles --- devices/client.lisp | 22 +-- devices/dispatching-device.lisp | 21 +-- devices/examples/osc-device-examples.lisp | 114 ++++++++++----- devices/listening-device.lisp | 14 +- devices/server.lisp | 92 ++++++++---- devices/transmitter.lisp | 88 ++++-------- osc-data.lisp | 49 +++++++ osc-dispatch.lisp | 38 +++-- osc.asd | 40 +++--- osc.lisp | 164 +++++++++++++++------- 10 files changed, 414 insertions(+), 228 deletions(-) create mode 100644 osc-data.lisp diff --git a/devices/client.lisp b/devices/client.lisp index 7374677..fd6d7dc 100644 --- a/devices/client.lisp +++ b/devices/client.lisp @@ -1,6 +1,6 @@ (cl:in-package #:osc) -(defun make-osc-client (&key(protocol :udp) debug-mode +(defun make-osc-client (&key (protocol :udp) debug-mode (buffer-size *default-osc-buffer-size*) address-tree cleanup-fun) (ecase protocol @@ -28,25 +28,25 @@ (defmethod make-client-responders ((client osc-client-udp)) (add-osc-responder client "/cl-osc/server/registered" - (cmd args device address port timetag) + (cmd args device address port timetag bundle) (format t "Registered with server at ~A~%" (make-addr+port-string address port))) (add-osc-responder client "/cl-osc/server/quit" - (cmd args device address port timetag) + (cmd args device address port timetag bundle) (format t "Server ~A has quit~%" (make-addr+port-string address port)))) (defgeneric register (client) (:method ((client osc-client-udp)) - (send client "/cl-osc/register" (port client)))) + (send-msg client "/cl-osc/register" (port client)))) (defmethod osc-device-cleanup ((device osc-client-udp)) - (send device "/cl-osc/quit") + (send-msg device "/cl-osc/quit") (call-next-method)) (defun make-osc-client-endpoint-tcp (socket debug-mode buffer-size address-tree clients &optional - cleanup-fun) + cleanup-fun) (socket-make-stream socket :input nil :output t :element-type '(unsigned-byte 8) @@ -74,14 +74,14 @@ (when (eq length 0) ; Closed by remote (sb-thread:terminate-thread sb-thread:*current-thread*)) - (multiple-value-bind (message timetag) - (decode-bundle buffer length) + (multiple-value-bind (data timetag) + (decode-bundle buffer :end length) (when (debug-mode receiver) - (print-osc-debug-msg receiver message length + (print-osc-debug-msg receiver data length (peer-address receiver) (peer-port receiver) timetag)) - (dispatch (address-tree receiver) message receiver - address port timetag)))) + (dispatch (address-tree receiver) data receiver + address port)))) (osc-device-cleanup receiver))) :name (format nil "osc-client-tcp-connection: ~A~%" (name receiver)))) diff --git a/devices/dispatching-device.lisp b/devices/dispatching-device.lisp index b6e5198..eaeb2c7 100644 --- a/devices/dispatching-device.lisp +++ b/devices/dispatching-device.lisp @@ -9,13 +9,13 @@ 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) + (multiple-value-bind (data timetag) + (osc:decode-bundle buffer :end length) (when (debug-mode receiver) - (print-osc-debug-msg receiver message length + (print-osc-debug-msg receiver data length address port timetag)) - (osc:dispatch (address-tree receiver) message - receiver address port timetag)))) + (dispatch (address-tree receiver) data receiver + address port)))) (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 device address port timetag bundle) + &body body) `(dp-register (address-tree ,dispatcher) ,cmd-name - (lambda (,cmd ,args ,disp ,addr ,port ,timetag) - (declare (ignorable ,cmd ,args ,disp ,addr - ,port ,timetag)) + (lambda (,cmd ,args ,device ,address ,port ,timetag + ,bundle) + (declare (ignorable ,cmd ,args ,device ,address + ,port ,timetag ,bundle)) ,@body))) (defgeneric remove-osc-responder (dispatcher address) diff --git a/devices/examples/osc-device-examples.lisp b/devices/examples/osc-device-examples.lisp index 9d13dea..da74c28 100644 --- a/devices/examples/osc-device-examples.lisp +++ b/devices/examples/osc-device-examples.lisp @@ -23,7 +23,7 @@ (peer-address *osc-transmitter*) (peer-port *osc-transmitter*) -(send *osc-transmitter* "/bar" 1 2 9) +(send-msg *osc-transmitter* "/bar" 1 2 9) (send-bundle *osc-transmitter* :time ; current real time @@ -37,6 +37,24 @@ (unix-time->timetag 1234567890.1234567d0) "/foo" 1 2 3) +;; The lower-level send function can be used to send message and +;; bundle objects directly. This allows more complex (nested) bundles +;; to be created. + +(send *osc-transmitter* (make-message "/foo" 1 2 3)) + +(send *osc-transmitter* (make-bundle :now + (make-message "/foo" 1 2 3))) + +(let ((bundle + (make-bundle :now + (make-message "/foo" '(1 2 3)) + (make-bundle :now + (make-bundle :now + (make-message "/bar" + '(10 20 30))))))) + (send *osc-transmitter* bundle)) + (quit *osc-transmitter*) (quit *osc-server*) @@ -65,7 +83,7 @@ (connect *osc-client* 57127 :host-name "localhost") -(send *osc-client* "/foo" 2 99) +(send-msg *osc-client* "/foo" 2 99) (send-bundle *osc-client* (unix-time->timetag 1234567890.1234567d0) @@ -76,45 +94,65 @@ (send-bundle *osc-client* :time "/foo" 1) ;; Using the server as a transmitter. -(send-to *osc-server* (address *osc-client*) (port *osc-client*) - "/bar" 1 2 3) +(send-msg-to *osc-server* + (address *osc-client*) (port *osc-client*) + "/bar" 1 2 3) + +(send-bundle-to *osc-server* + (address *osc-client*) (port *osc-client*) + :now "/bar" 1 2 3) ;; If a client is registered... -(send-to-client *osc-server* (make-name-string *osc-client*) - "/bar" 2 99) +(send-msg-to-client *osc-server* (make-name-string *osc-client*) + "/bar" 2 99) (register *osc-client*) -(send-to-client *osc-server* (make-name-string *osc-client*) - "/bar" 2 99) +(send-msg-to-client *osc-server* (make-name-string *osc-client*) + "/bar" 2 99) (send-bundle-to-client *osc-server* (make-name-string *osc-client*) - :timeq "/bar" 2 99) + :time "/bar" 2 99) (add-osc-responder *osc-server* "/echo-sum" - (cmd args device address port timetag) - (send-to device address port "/echo-answer" (apply #'+ args))) + (cmd args dev addr port timetag bundle) + (send-msg-to dev addr port + "/echo-answer" (apply #'+ args))) (add-osc-responder *osc-client* "/echo-answer" - (cmd args device address port timetag) - (format t "~%Sum is ~A" (car args))) + (cmd args dev addr port timetag bundle) + (format t "Sum is ~a~%" (car args))) -(send *osc-client* "/echo-sum" 1 2 3 4) +(send-msg *osc-client* "/echo-sum" 1 2 3 4) (add-osc-responder *osc-server* "/timetag+1" - (cmd args device address port timetag) - (send-bundle-to device address port (timetag+ timetag 1) "/future")) + (cmd args dev addr port timetag bundle) + (send-bundle-to dev addr port (timetag+ timetag 1) "/the-future")) (send-bundle *osc-client* (get-current-timetag) "/timetag+1") ;; Send a messages to all registered clients. -(send-all *osc-server* "/foo" 1 2 3) +(send-msg-all *osc-server* "/foo" 1 2 3) (send-bundle-all *osc-server* :now "/foo" 1 2 3) +(defparameter *osc-client2* (make-osc-client + :protocol :udp + :debug-mode t)) + +(connect *osc-client2* 57127) +(register *osc-client2*) + +(add-osc-responder *osc-server* "/echo-sum" + (cmd args dev addr port timetag bundle) + (send-msg-all dev "/echo-answer" (apply #'+ args))) + +(send-msg *osc-client* "/echo-sum" 1 2 3 4) + (quit *osc-client*) +(quit *osc-client2*) (quit *osc-server*) @@ -137,11 +175,11 @@ (device-socket-name *osc-client*) (device-socket-peername *osc-client*) -(send *osc-client* "/foo" 1 2 3) +(send-msg *osc-client* "/foo" 1 2 3) -(send-to-client *osc-server* (make-name-string - *osc-client*) - "/foo" 1 2 3) +(send-msg-to-client *osc-server* (make-name-string + *osc-client*) + "/foo" 1 2 3) (defparameter *osc-client2* (make-osc-client :protocol :tcp @@ -153,30 +191,30 @@ (device-socket-name *osc-client2*) -(send *osc-client2* "/bar" 4 5 6 9) +(send-msg *osc-client2* "/bar" 4 5 6 9) (print-clients *osc-server*) (add-osc-responder *osc-server* "/print-sum" - (cmd args device address port timetag) + (cmd args dev addr port timetag bundle) (format t "Sum = ~A~%" (apply #'+ args))) -(send *osc-client2* "/print-sum" 4 5 6 9) +(send-msg *osc-client2* "/print-sum" 4 5 6 9) (add-osc-responder *osc-server* "/echo-sum" - (cmd args disp address port timetag) - (send disp cmd (apply #'+ args))) + (cmd args dev addr port timetag bundle) + (send-msg dev cmd (apply #'+ args))) -(send *osc-client2* "/echo-sum" 4 5 6 9) +(send-msg *osc-client2* "/echo-sum" 4 5 6 9) -(send-all *osc-server* "/bar" 1 2 3) ; send to all peers +(send-msg-all *osc-server* "/bar" 1 2 3) ; send to all peers (add-osc-responder *osc-server* "/echo-sum-all" - (cmd args disp address port timetag) - (send-all disp cmd (apply #'+ args))) + (cmd args dev addr port timetag bundle) + (send-msg-all dev cmd (apply #'+ args))) -; Send to all peers (excluding self). -(send *osc-client2* "/echo-sum-all" 1 2 3) +; Send to all peers (including self). +(send-msg *osc-client2* "/echo-sum-all" 1 2 3) (quit *osc-client*) (quit *osc-client2*) @@ -204,15 +242,15 @@ c=OSCresponder(nil, {|t,r,msg,addr| [t,r,msg,addr].postln}).add ;;--------------------------------------------------------------------- -(send *osc-client* "/foo" 1 2 3) +(send-msg *osc-client* "/foo" 1 2 3) (send-bundle *osc-client* (get-current-timetag) "/foo" 3) (add-osc-responder *osc-client* "/echo-sum" - (cmd args disp addr port timetag) - (send disp cmd (apply #'+ args))) + (cmd args dev addr port timetag bundle) + (send-msg dev cmd (apply #'+ args))) ;;--------------------------------------------------------------------- ;; Send /echo-sum from sc, and lisp returns the sum. @@ -240,15 +278,15 @@ n.sendMsg('/echo-sum', 1, 2, 3) // send numbers, lisp returns sum. (connect *osc-client* 57110 :host-name "localhost" :port 57127) -(send *osc-client* "/s_new" "default" 1001 0 0 "freq" 500) +(send-msg *osc-client* "/s_new" "default" 1001 0 0 "freq" 500) -(send *osc-client* "/n_free" 1001) +(send-msg *osc-client* "/n_free" 1001) (send-bundle *osc-client* (timetag+ (get-current-timetag) 2) ; 2 secs later "/s_new" "default" 1001 0 0 "freq" 500) -(send *osc-client* "/n_free" 1001) +(send-msg *osc-client* "/n_free" 1001) (quit *osc-client*) ; Sends default /quit notification which scsynth ; ignores. Ideally osc-client should be subclassed diff --git a/devices/listening-device.lisp b/devices/listening-device.lisp index 9964abf..388cecd 100644 --- a/devices/listening-device.lisp +++ b/devices/listening-device.lisp @@ -19,9 +19,13 @@ (fill (socket-buffer device) 0) (call-next-method)) -(defun print-osc-debug-msg (receiver message length address port - 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 +(defun print-osc-debug-msg (receiver data length address port + timetag &optional (stream t)) + (format stream + "~&~a~%bytes rx:~a~a~%from:~a~a~a ~a~%timetag:~a~a~%unix-time:~a~f~%data:~a~a" + (name receiver) #\Tab length #\Tab #\Tab address port #\Tab timetag #\Tab - (when timetag (timetag->unix-time timetag)))) + (when timetag (timetag->unix-time timetag)) + #\Tab #\Tab) + (format-osc-data data stream) + (format stream "~%")) diff --git a/devices/server.lisp b/devices/server.lisp index df72d6f..c938437 100644 --- a/devices/server.lisp +++ b/devices/server.lisp @@ -80,13 +80,13 @@ (defmethod make-server-responders ((server osc-server-udp)) (add-osc-responder server "/cl-osc/register" - (cmd args device address port timetag) + (cmd args device address port timetag bundle) (let ((listening-port (car args))) ; Optional port for sending - ; return messages to. + ; return messages. (register-udp-client device address (if listening-port listening-port port)))) (add-osc-responder server "/cl-osc/quit" - (cmd args device address port timetag) + (cmd args device address port timetag bundle) (unregister-udp-client device address port))) (defun register-udp-client (server addr port) @@ -107,10 +107,10 @@ (notify-registered server client-name))) (defun notify-registered (server client-name) - (send-to-client server client-name "/cl-osc/server/registered")) + (send-msg-to-client server client-name "/cl-osc/server/registered")) (defun notify-quit (server client-name) - (send-to-client server client-name "/cl-osc/server/quit")) + (send-msg-to-client server client-name "/cl-osc/server/quit")) ;;;===================================================================== @@ -153,30 +153,72 @@ ;;; Server sending functions ;;;===================================================================== -(defgeneric send-to-client (server client-name &rest msg) - (:method :around ((server osc-server) client-name &rest msg) +;; Send to a client + +(defgeneric send-to-client (server client-name data) + (:method :around ((server osc-server) client-name data) (let ((client (gethash client-name (clients server)))) (if client - (apply #'call-next-method server client msg) + (call-next-method server client data) (warn "No client called ~A~%" client-name))))) -(defmethod send-to-client ((server osc-server-udp) client-name &rest - msg) - (apply #'send-to server (first client-name) (second client-name) - msg)) +(defmethod send-to-client ((server osc-server-udp) client-name data) + (send-to server (first client-name) (second client-name) data)) -(defmethod send-to-client ((server osc-server-tcp) client &rest msg) - (apply #'send client msg)) +(defmethod send-to-client ((server osc-server-tcp) client data) + (send client data)) -(defgeneric send-bundle-to-client (server client-name timetag &rest - 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))))) +(defgeneric send-msg-to-client (server client-name command &rest args) + (:method ((server osc-server) client-name command &rest args) + (let ((message (apply #'make-message command args))) + (send-to-client server client-name message)))) -(defmethod send-bundle-to-client ((server osc-server-udp) client-name - timetag &rest msg) - (apply #'send-bundle-to server (first client-name) - (second client-name) timetag msg)) +(defgeneric send-bundle-to-client (server client-name timetag command + &rest args) + (:method ((server osc-server) client-name timetag command &rest + args) + (let ((bundle (make-bundle timetag + (apply #'make-message command args)))) + (send-to-client server client-name bundle)))) + +;; Send all + +(defgeneric send-all (server data)) + +(defmethod send-all ((server osc-server-udp) data) + (loop for addr+port being the hash-value in (clients server) + do (send-to server (first addr+port) (second addr+port) data))) + +(defmethod send-all ((server osc-server-tcp) data) + (loop for endpoint being the hash-value in (clients server) + do (send endpoint data))) + +(defmethod send-all ((client-endpoint osc-client-endpoint) data) + (loop for endpoint being the hash-value in (clients client-endpoint) + ;; FIXME: Don't not reply to the sender in this case so that the + ;; behaviour of send-all is uniform for both UDP and TCP. But + ;; could be useful to have a means of broadcasting messages to + ;; all clients of a server except the client that generated the + ;; message. + ;; + ;; unless (eq endpoint client-endpoint) ; don't send to sender + do (send endpoint data))) + +(defgeneric send-msg-all (server command &rest args) + (:method ((server osc-server) command &rest args) + (let ((message (apply #'make-message command args))) + (send-all server message))) + (:method ((client-endpoint osc-client-endpoint) command &rest args) + (let ((message (apply #'make-message command args))) + (send-all client-endpoint message)))) + +(defgeneric send-bundle-all (server timetag command &rest args) + (:method ((server osc-server) timetag command &rest args) + (let ((bundle (make-bundle timetag + (apply #'make-message command args)))) + (send-all server bundle))) + (:method ((client-endpoint osc-client-endpoint) timetag command + &rest args) + (let ((bundle (make-bundle timetag + (apply #'make-message command args)))) + (send-all client-endpoint bundle)))) diff --git a/devices/transmitter.lisp b/devices/transmitter.lisp index a2a6bea..9e17059 100644 --- a/devices/transmitter.lisp +++ b/devices/transmitter.lisp @@ -59,69 +59,41 @@ `(progn (write-sequence ,@msg ,stream) (finish-output ,stream))) -(defgeneric send (transmitter &rest msg-args) - (:method ((transmitter osc-transmitter) &rest msg-args) - (let ((msg (apply #'encode-message msg-args))) +(defgeneric send (transmitter data) + (:method ((transmitter osc-transmitter) data) + (let ((bytes (encode-osc-data data))) (osc-write-to-stream - (slot-value (socket transmitter) 'stream) msg)))) + (slot-value (socket transmitter) 'stream) bytes)))) -(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)))) +(defgeneric send-msg (transmitter command &rest args) + (:method ((transmitter osc-transmitter) command &rest args) + (let ((message (apply #'make-message command args))) + (send transmitter message)))) -;; Unconnected sending +(defgeneric send-bundle (transmitter timetag command &rest args) + (:method ((transmitter osc-transmitter) timetag command &rest args) + (let ((bundle (make-bundle timetag + (apply #'make-message command args)))) + (send transmitter bundle)))) -(defgeneric send-to (transmitter address port &rest msg-args) - (:method ((transmitter osc-transmitter-udp) address port &rest - msg-args) +;; Unconnected sending (UDP only) + +(defgeneric send-to (transmitter address port data) + (:method ((transmitter osc-transmitter-udp) address port data) (socket-send (socket transmitter) - (apply #'encode-message msg-args) nil + (encode-osc-data data) nil :address (list address port)))) -(defgeneric send-bundle-to (transmitter address port timestamp &rest - msg-args) - (:method ((transmitter osc-transmitter-udp) address port timestamp - &rest msg-args) - (socket-send (socket transmitter) - (apply #'encode-bundle msg-args (list timestamp)) nil - :address (list address port)))) +(defgeneric send-msg-to (transmitter address port command &rest args) + (:method ((transmitter osc-transmitter-udp) address port command + &rest args) + (let ((message (apply #'make-message command args))) + (send-to transmitter address port message)))) -;; Server functions - -(defgeneric send-all (server &rest msg-args)) - -(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))) - -(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) - (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))) - -(defgeneric send-bundle-all (server timetag &rest msg-args)) - -(defmethod send-bundle-all ((server osc-server-udp) timetag &rest - 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))) - -(defmethod send-bundle-all ((server osc-server-tcp) timetag &rest - 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) - (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))) +(defgeneric send-bundle-to (transmitter address port timetag command + &rest args) + (:method ((transmitter osc-transmitter-udp) address port timetag + command &rest args) + (let ((bundle (make-bundle timetag + (apply #'make-message command args)))) + (send-to transmitter address port bundle)))) diff --git a/osc-data.lisp b/osc-data.lisp new file mode 100644 index 0000000..55cd1b5 --- /dev/null +++ b/osc-data.lisp @@ -0,0 +1,49 @@ +(cl:in-package #:osc) + +;; Classes + +(defclass osc-data () ()) + +(defclass message (osc-data) + ((command + :reader command + :initarg :command) + (args + :reader args + :initarg :args + :initform nil))) + +(defclass bundle (osc-data) + ((timetag + :reader timetag + :initarg :timetag + :initform :now) + (elements + :reader elements + :initarg :elements + :initform nil))) + +;; Constructors + +(defun make-message (command &rest args) + (make-instance 'message + :command command + :args args)) + +(defun make-bundle (timetag &rest elements) + (make-instance 'bundle + :timetag timetag + :elements elements)) + +(defgeneric format-osc-data (data &optional stream)) + +(defmethod format-osc-data ((message message) &optional (stream t)) + (format stream "~a~{ ~a~}~%" + (command message) + (args message))) + +(defmethod format-osc-data ((bundle bundle) &optional (stream t)) + (format stream "~&[ ~a~%" (timetag bundle)) + (dolist (element (elements bundle)) + (format-osc-data element stream)) + (format stream "~&]~%")) diff --git a/osc-dispatch.lisp b/osc-dispatch.lisp index 99ff12c..0e20f6b 100644 --- a/osc-dispatch.lisp +++ b/osc-dispatch.lisp @@ -47,27 +47,41 @@ ;;;; ; ; ; ;; (defun dp-register (tree address function) - "registers a function to respond to incoming osc message. since + "Registers a function to respond to incoming osc messages. Since only one function should be associated with an address, any - previous registration will be overwritten" + previous registration will be overwritten." (setf (gethash address tree) function)) (defun dp-remove (tree address) - "removes the function associated with the given 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) - "calls the function(s) matching the address(pattern) in the osc - message with the data contained in the message" - (let ((pattern (car osc-message))) +(defgeneric dispatch (tree data device address port &optional timetag + parent-bundle)) + +(defmethod dispatch (tree (data message) device address port &optional + timetag + parent-bundle) + "Calls the function(s) matching the address(pattern) in the osc +message passing the message object, the recieving device, and +optionally in the case where a message is part of a bundle, the +timetag of the bundle and the enclosing bundle." + (let ((pattern (command data))) (dolist (x (dp-match tree pattern)) (unless (eq x NIL) - (funcall x (car osc-message) (cdr osc-message) device address - port timetag))))) + (funcall x (command data) (args data) device address port + timetag parent-bundle))))) + +(defmethod dispatch (tree (data bundle) device address port &optional + timetag + parent-bundle) + "Dispatches each bundle element in sequence." + (declare (ignore timetag parent-bundle)) + (dolist (element (elements data)) + (dispatch tree element device address port (timetag data) data))) diff --git a/osc.asd b/osc.asd index 9f8244e..927c639 100644 --- a/osc.asd +++ b/osc.asd @@ -8,22 +8,24 @@ :licence "LLGPL" :description "The Open Sound Control protocol, aka OSC" :version "0.5" - :components ((:file "osc" :depends-on ("osc-time")) - (:file "osc-dispatch" :depends-on ("osc")) - (:file "osc-time" :depends-on ("package")) - (:file "package") - (:module "devices" - :depends-on ("package") - ::components - ((:file "socket-functions") - (:file "device") - (:file "transmitter" - :depends-on ("device" - "socket-functions")) - (:file "listening-device" - :depends-on ("transmitter")) - (:file "dispatching-device" - :depends-on ("listening-device")) - (:file "client" - :depends-on ("dispatching-device")) - (:file "server" :depends-on ("client")))))) + :components + ((:file "osc" :depends-on ("osc-data" "osc-time")) + (:file "osc-data" :depends-on ("package")) + (:file "osc-dispatch" :depends-on ("osc")) + (:file "osc-time" :depends-on ("package")) + (:file "package") + (:module "devices" + :depends-on ("package" "osc-data") + ::components + ((:file "socket-functions") + (:file "device") + (:file "transmitter" + :depends-on ("device" + "socket-functions")) + (:file "listening-device" + :depends-on ("transmitter")) + (:file "dispatching-device" + :depends-on ("listening-device")) + (:file "client" + :depends-on ("dispatching-device")) + (:file "server" :depends-on ("client")))))) diff --git a/osc.lisp b/osc.lisp index 5571842..4e09cbf 100644 --- a/osc.lisp +++ b/osc.lisp @@ -50,28 +50,41 @@ ;; ;;;; ;; ;; ; ; ;; ; ; ; ; -(defun encode-bundle (data &optional timetag) - "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 - (if timetag - (encode-timetag timetag) - (encode-timetag :now)) - (if (listp (car data)) - (apply #'cat (mapcar #'encode-bundle-elt data)) - (encode-bundle-elt data)))) +(defparameter *debug* 0 + "Set debug verbosity for core library functions. Currently levels + are 0-3.") -(defun encode-bundle-elt (data) - (let ((message (apply #'encode-message data))) - (cat (encode-int32 (length message)) message))) +(defgeneric encode-osc-data (data)) -(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))) +(defmethod encode-osc-data ((data message)) + "Encode an osc message with the given address and args." + (with-slots (command args) data + (concatenate '(vector (unsigned-byte 8)) + (encode-address command) + (encode-typetags args) + (encode-args args)))) + +(defmethod encode-osc-data ((data bundle)) + "Encode an osc bundle. A bundle contains a timetag (symbol or 64bit + int) and a list of message or nested bundle elements." + (with-slots (timetag elements) data + (cat '(35 98 117 110 100 108 101 0) ; #bundle + (if timetag + (encode-timetag timetag) + (encode-timetag :now)) + (apply #'cat (mapcar #'encode-bundle-elt elements))))) + +(defgeneric encode-bundle-elt (data)) + +(defmethod encode-bundle-elt ((data message)) + (let ((bytes (encode-osc-data data))) + (cat (encode-int32 (length bytes)) bytes))) + +(defmethod encode-bundle-elt ((data bundle)) + (let ((bytes (encode-osc-data data))) + (cat (encode-int32 (length bytes)) bytes))) + +;; Auxilary functions (defun encode-address (address) (cat (map 'vector #'char-code address) @@ -106,12 +119,12 @@ (cat lump (pad (padding-length (length lump)))))) -(defun encode-data (data) - "encodes data in a format suitable for an OSC message" +(defun encode-args (args) + "encodes args 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 args) (typecase x (integer (enc encode-int32)) (float (enc encode-float32)) @@ -126,33 +139,84 @@ ;; ;;; ;; ;; ; ; ; ; ; ; -(defun decode-bundle (data &optional bundle-length) - "Decodes an osc bundle into a list of decoded-messages, which has an -osc-timetag as its first element. An optional buffer-length argument -can be supplied (i.e. the length value returned by socket-receive), -otherwise the entire buffer is decoded - in which case, if you are -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)))) +(defun bundle-p (buffer &optional (start 0)) + "A bundle begins with '#bundle' (8 bytes). The start argument should +index the beginning of a bundle in the buffer." + (= 35 (elt buffer start))) + +(defun get-timetag (buffer &optional (start 0)) + "Bytes 8-15 are the bundle timestamp. The start argument should +index the beginning of a bundle in the buffer." + (decode-timetag (subseq buffer + (+ 8 start) + (+ 16 start)))) + +(defun get-bundle-element-length (buffer &optional (start 16)) + "Bytes 16-19 are the size of the bundle element. The start argument +should index the beginning of the bundle element (length, content) +pair in the buffer." + (decode-int32 (subseq buffer start (+ 4 start)))) + +(defun get-bundle-element (buffer &optional (start 16)) + "Bytes 20 upto to the length of the content (defined by the +preceeding 4 bytes) are the content of the bundle. The start argument +should index the beginning of the bundle element (length, content) +pair in the buffer." + (let ((length (get-bundle-element-length buffer start))) + (subseq buffer + (+ 4 start) + (+ (+ 4 start) + (+ length))))) + +(defun split-sequence-by-n (sequence n) + (loop :with length := (length sequence) + :for start :from 0 :by n :below length + :collecting (coerce + (subseq sequence start (min length (+ start n))) + 'list))) + +(defun print-buffer (buffer &optional (n 8)) + (format t "~%~{~{ ~5d~}~%~}Total: ~a bytes~2%" + (split-sequence-by-n buffer n) + (length buffer))) + +(defun decode-bundle (buffer &key (start 0) end) + "Decodes an osc bundle/message into a bundle/message object. Bundles + comprise an osc-timetag and a list of elements, which may be + messages or bundles recursively. An optional end argument can be + supplied (i.e. the length value returned by socket-receive, or the + element length in the case of nested bundles), otherwise the entire + buffer is decoded - in which case, if you are reusing buffers, you + are responsible for ensuring that the buffer does not contain stale + data." + (unless end + (setf end (- (length buffer) start))) + (when (>= *debug* 2) + (format t "~%Buffer start: ~a end: ~a~%" start end) + (print-buffer (subseq buffer start end))) + (if (bundle-p buffer start) + ;; Bundle + (let ((timetag (get-timetag buffer start))) + (incf start (+ 8 8)) ; #bundle, timetag bytes + (loop while (< start end) + for element-length = (get-bundle-element-length + buffer start) + do (incf start 4) ; length bytes + when (>= *debug* 1) + do (format t "~&Bundle element length: ~a~%" element-length) + collect (decode-bundle buffer + :start start + :end (+ start element-length)) + into elements + do (incf start (+ element-length)) + finally (return + (values (apply #'make-bundle timetag elements) + timetag)))) + ;; Message + (let ((message + (decode-message + (subseq buffer start (+ start end))))) + (apply #'make-message (car message) (cdr message))))) (defun decode-message (message) "reduces an osc message to an (address . data) pair. .." -- 2.39.5 From ccb3f2d5a9f78f8329277ebdde28b3cba92136d7 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 21 Aug 2015 15:36:49 +0100 Subject: [PATCH 21/27] update README --- README.md | 48 +++++++++++++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 17 deletions(-) diff --git a/README.md b/README.md index b8590b7..f894f4a 100644 --- a/README.md +++ b/README.md @@ -1,21 +1,31 @@ # Open Sound Control -This is a common lisp implementation of the Open Sound Control Protocol aka OSC. The code should be close to the 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/ +This is a common lisp implementation of the Open Sound Control +Protocol aka OSC. The code should be close to the 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 devices/examples/osc-device-examples.lisp contains examples of a +higher-level API for sending and receiving OSC messages. the current version of this code is avilable from github - git clone https://github.com/zzkt/osc + git clone https://github.com/jamieforth/osc -or via asdf-install.. . - - (asdf-install:install :osc) + (fork from https://github.com/zzkt/osc) ## limitations - - doesnt send nested bundles or syncronisable timetags - will raise an exception if the input is malformed - doesn't do any pattern matching on addresses - - float en/decoding only tested on sbcl, cmucl, openmcl and allegro + - float en/decoding only tested on sbcl, cmucl, openmcl and allegro - only supports the type(tag)s specified in the OSC spec ## things to do in :osc @@ -24,27 +34,32 @@ or via asdf-install.. . - data checking and error handling - portable en/decoding of floats -=> ieee754 tests - doubles and other defacto typetags - - correct en/decoding of timetags ## things to do in :osc-ex[tensions|tras] - - liblo like network wrapping + - liblo like network wrapping - add namespace exploration using cl-zeroconf # changes + - 2015-08-21 + - implement nested bundles - 2011-04-19 - converted repo from darcs->git + - 2010-09-25 + - add osc-devices API + - 2010-09-10 + - implement timetags - 2007-02-20 - version 0.5 - - Allegro CL float en/decoding from vincent akkermans + - Allegro CL float en/decoding from vincent akkermans - 2006-02-11 - version 0.4 - - partial timetag implemetation + - partial timetag implementation - 2005-12-05 - version 0.3 - fixed openmcl float bug (decode-uint32) - - 2005-11-29 + - 2005-11-29 - version 0.2 - openmcl float en/decoding - 2005-08-12 @@ -57,16 +72,15 @@ or via asdf-install.. . - bundle and blob en/de- coding - 2005-03-05 - 'declare' scattering and other optimisations - - 2005-02-08 + - 2005-02-08 - in-package'd - basic dispatcher - 2005-03-01 - fixed address string bug - - 2005-01-26 + - 2005-01-26 - fixed string handling bug - - 2005-01-24 + - 2005-01-24 - sends and receives multiple arguments - tests in osc-tests.lisp - - 2004-12-18 + - 2004-12-18 - initial version, single args only - -- 2.39.5 From 9fde4ea5ce6c089189f0cfcff8ad6dd14fdd59c2 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 21 Aug 2015 16:30:14 +0100 Subject: [PATCH 22/27] truncate long messages when printing osc debug messages --- devices/listening-device.lisp | 2 +- osc-data.lisp | 22 +++++++++++++++------- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/devices/listening-device.lisp b/devices/listening-device.lisp index 388cecd..a04267b 100644 --- a/devices/listening-device.lisp +++ b/devices/listening-device.lisp @@ -27,5 +27,5 @@ address port #\Tab timetag #\Tab (when timetag (timetag->unix-time timetag)) #\Tab #\Tab) - (format-osc-data data stream) + (format-osc-data data :stream stream) (format stream "~%")) diff --git a/osc-data.lisp b/osc-data.lisp index 55cd1b5..759abb9 100644 --- a/osc-data.lisp +++ b/osc-data.lisp @@ -35,15 +35,23 @@ :timetag timetag :elements elements)) -(defgeneric format-osc-data (data &optional stream)) +(defgeneric format-osc-data (data &key stream width)) -(defmethod format-osc-data ((message message) &optional (stream t)) - (format stream "~a~{ ~a~}~%" - (command message) - (args message))) +(defmethod format-osc-data ((message message) &key (stream t) + (width 80)) + (let ((args-string (format nil "~{~a~^ ~}" (args message)))) + (when (> (length args-string) width) + (setf args-string + (concatenate 'string + (subseq args-string 0 width) + "..."))) + (format stream "~a~a ~a~%" + #\Tab + (command message) + args-string))) -(defmethod format-osc-data ((bundle bundle) &optional (stream t)) +(defmethod format-osc-data ((bundle bundle) &key (stream t) (width 80)) (format stream "~&[ ~a~%" (timetag bundle)) (dolist (element (elements bundle)) - (format-osc-data element stream)) + (format-osc-data element :stream stream :width width)) (format stream "~&]~%")) -- 2.39.5 From fb81d63d1e82dcfcdb19c5c15746e86992adb1be Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Fri, 21 Aug 2015 18:22:49 +0100 Subject: [PATCH 23/27] add convenience functions for constructing message and bundle objects --- devices/examples/osc-device-examples.lisp | 18 +-- devices/server.lisp | 18 +-- devices/transmitter.lisp | 12 +- osc-data.lisp | 17 ++- osc.lisp | 4 +- package.lisp | 133 ++++++++++++---------- 6 files changed, 110 insertions(+), 92 deletions(-) diff --git a/devices/examples/osc-device-examples.lisp b/devices/examples/osc-device-examples.lisp index da74c28..4e965cd 100644 --- a/devices/examples/osc-device-examples.lisp +++ b/devices/examples/osc-device-examples.lisp @@ -41,18 +41,18 @@ ;; bundle objects directly. This allows more complex (nested) bundles ;; to be created. -(send *osc-transmitter* (make-message "/foo" 1 2 3)) +(send *osc-transmitter* (message "/foo" 1 2 3)) -(send *osc-transmitter* (make-bundle :now - (make-message "/foo" 1 2 3))) +(send *osc-transmitter* (bundle :now + (message "/foo" 1 2 3))) (let ((bundle - (make-bundle :now - (make-message "/foo" '(1 2 3)) - (make-bundle :now - (make-bundle :now - (make-message "/bar" - '(10 20 30))))))) + (bundle :now + (message "/foo" '(1 2 3)) + (bundle :now + (bundle :now + (message "/bar" + '(10 20 30))))))) (send *osc-transmitter* bundle)) (quit *osc-transmitter*) diff --git a/devices/server.lisp b/devices/server.lisp index c938437..d0ba6ea 100644 --- a/devices/server.lisp +++ b/devices/server.lisp @@ -170,15 +170,15 @@ (defgeneric send-msg-to-client (server client-name command &rest args) (:method ((server osc-server) client-name command &rest args) - (let ((message (apply #'make-message command args))) + (let ((message (make-message command args))) (send-to-client server client-name message)))) (defgeneric send-bundle-to-client (server client-name timetag command &rest args) (:method ((server osc-server) client-name timetag command &rest args) - (let ((bundle (make-bundle timetag - (apply #'make-message command args)))) + (let ((bundle (bundle timetag + (make-message command args)))) (send-to-client server client-name bundle)))) ;; Send all @@ -206,19 +206,19 @@ (defgeneric send-msg-all (server command &rest args) (:method ((server osc-server) command &rest args) - (let ((message (apply #'make-message command args))) + (let ((message (make-message command args))) (send-all server message))) (:method ((client-endpoint osc-client-endpoint) command &rest args) - (let ((message (apply #'make-message command args))) + (let ((message (make-message command args))) (send-all client-endpoint message)))) (defgeneric send-bundle-all (server timetag command &rest args) (:method ((server osc-server) timetag command &rest args) - (let ((bundle (make-bundle timetag - (apply #'make-message command args)))) + (let ((bundle (bundle timetag + (make-message command args)))) (send-all server bundle))) (:method ((client-endpoint osc-client-endpoint) timetag command &rest args) - (let ((bundle (make-bundle timetag - (apply #'make-message command args)))) + (let ((bundle (bundle timetag + (make-message command args)))) (send-all client-endpoint bundle)))) diff --git a/devices/transmitter.lisp b/devices/transmitter.lisp index 9e17059..faa3cd2 100644 --- a/devices/transmitter.lisp +++ b/devices/transmitter.lisp @@ -67,13 +67,13 @@ (defgeneric send-msg (transmitter command &rest args) (:method ((transmitter osc-transmitter) command &rest args) - (let ((message (apply #'make-message command args))) + (let ((message (make-message command args))) (send transmitter message)))) (defgeneric send-bundle (transmitter timetag command &rest args) (:method ((transmitter osc-transmitter) timetag command &rest args) - (let ((bundle (make-bundle timetag - (apply #'make-message command args)))) + (let ((bundle (bundle timetag + (make-message command args)))) (send transmitter bundle)))) ;; Unconnected sending (UDP only) @@ -87,13 +87,13 @@ (defgeneric send-msg-to (transmitter address port command &rest args) (:method ((transmitter osc-transmitter-udp) address port command &rest args) - (let ((message (apply #'make-message command args))) + (let ((message (make-message command args))) (send-to transmitter address port message)))) (defgeneric send-bundle-to (transmitter address port timetag command &rest args) (:method ((transmitter osc-transmitter-udp) address port timetag command &rest args) - (let ((bundle (make-bundle timetag - (apply #'make-message command args)))) + (let ((bundle (bundle timetag + (make-message command args)))) (send-to transmitter address port bundle)))) diff --git a/osc-data.lisp b/osc-data.lisp index 759abb9..9114c4f 100644 --- a/osc-data.lisp +++ b/osc-data.lisp @@ -25,16 +25,26 @@ ;; Constructors -(defun make-message (command &rest args) +(defun make-message (command args) + (unless (listp args) + (setf args (list args))) (make-instance 'message :command command :args args)) -(defun make-bundle (timetag &rest elements) +(defun message (command &rest args) + (make-message command args)) + +(defun make-bundle (timetag elements) + (unless (listp elements) + (setf elements (list elements))) (make-instance 'bundle :timetag timetag :elements elements)) +(defun bundle (timetag &rest elements) + (make-bundle timetag elements)) + (defgeneric format-osc-data (data &key stream width)) (defmethod format-osc-data ((message message) &key (stream t) @@ -45,8 +55,7 @@ (concatenate 'string (subseq args-string 0 width) "..."))) - (format stream "~a~a ~a~%" - #\Tab + (format stream "~a ~a~%" (command message) args-string))) diff --git a/osc.lisp b/osc.lisp index 4e09cbf..d1d575e 100644 --- a/osc.lisp +++ b/osc.lisp @@ -210,13 +210,13 @@ pair in the buffer." into elements do (incf start (+ element-length)) finally (return - (values (apply #'make-bundle timetag elements) + (values (make-bundle timetag elements) timetag)))) ;; Message (let ((message (decode-message (subseq buffer start (+ start end))))) - (apply #'make-message (car message) (cdr message))))) + (make-message (car message) (cdr message))))) (defun decode-message (message) "reduces an osc message to an (address . data) pair. .." diff --git a/package.lisp b/package.lisp index 60a8db5..8fc0e04 100644 --- a/package.lisp +++ b/package.lisp @@ -1,67 +1,76 @@ (defpackage :osc (: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 + (:export + #:make-message + #:message + #:make-bundle + #:bundle + #:command + #:args + #:timetag + #:elements + #:encode-message + #: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* ; sockets - #: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)) -- 2.39.5 From be1a4f5d4b40c2b6473fbbfa176f0c6d666bbc9d Mon Sep 17 00:00:00 2001 From: ErikR Date: Tue, 25 Aug 2015 21:25:05 +0200 Subject: [PATCH 24/27] Encoding and decoding blobs now follows the spec with regards to size --- osc.lisp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/osc.lisp b/osc.lisp index cf7cab5..c63951d 100644 --- a/osc.lisp +++ b/osc.lisp @@ -199,11 +199,12 @@ (setf acc (subseq acc pointer)))) ((eq x (char-code #\b)) (let* ((size (decode-int32 (subseq acc 0 4))) - (end (padded-length (+ 4 size)))) + (bl (+ 4 size)) + (end (+ bl (mod (- 4 bl) 4)))) ; NOTE: cannot use (padded-length bl), as it is not the same algorithm. Blobs of 4, 8, 12 etc bytes should not be padded! (push (decode-blob (subseq acc 0 end)) result) (setf acc (subseq acc end)))) - (t (error "unrecognised typetag")))) + (t (error "unrecognised typetag ~a" x)))) tags) (nreverse result)))) @@ -340,7 +341,7 @@ "encodes a blob from a given vector" (let ((bl (length blob))) (cat (encode-int32 bl) blob - (pad (padding-length bl))))) + (pad (mod (- 4 bl) 4))))) ; NOTE: cannot use (padding-length bl), as it is not the same algorithm. Blobs of 4, 8, 12 etc bytes should not be padded! ;; utility functions for osc-string/padding slonking -- 2.39.5 From 953af87fe49b58a3a345630dedeaa2d26841a596 Mon Sep 17 00:00:00 2001 From: ErikR Date: Tue, 25 Aug 2015 21:54:38 +0200 Subject: [PATCH 25/27] Added support for 64-bit integers --- osc.lisp | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 54 insertions(+), 4 deletions(-) diff --git a/osc.lisp b/osc.lisp index c63951d..4fb690f 100644 --- a/osc.lisp +++ b/osc.lisp @@ -96,6 +96,7 @@ f => #(102) => float s => #(115) => string b => #(98) => blob + h => #(104) => int64 and considers non int/float/string data to be a blob." (let ((lump (make-array 0 :adjustable t @@ -106,7 +107,7 @@ (write-to-vector #\,) (dolist (x data) (typecase x - (integer (write-to-vector #\i)) + (integer (if (>= x 4294967296) (write-to-vector #\h) (write-to-vector #\i))) (float (write-to-vector #\f)) (simple-string (write-to-vector #\s)) (t (write-to-vector #\b))))) @@ -120,8 +121,8 @@ `(setf lump (cat lump (,f x))))) (dolist (x data) (typecase x - (integer (enc encode-int32)) - (float (enc encode-float32)) + (integer (if (>= x 4294967296) (enc encode-int64) (enc encode-int32))) + (float (enc encode-float32)) (simple-string (enc encode-string)) (t (enc encode-blob)))) lump))) @@ -174,7 +175,8 @@ i => #(105) => int32 f => #(102) => float s => #(115) => string - b => #(98) => blob" + b => #(98) => blob + h => #(104) => int64" (let ((div (position 0 data))) (let ((tags (subseq data 1 div)) @@ -187,6 +189,10 @@ (push (decode-int32 (subseq acc 0 4)) result) (setf acc (subseq acc 4))) + ((eq x (char-code #\h)) + (push (decode-uint64 (subseq acc 0 8)) + result) + (setf acc (subseq acc 8))) ((eq x (char-code #\f)) (push (decode-float32 (subseq acc 0 4)) result) @@ -317,6 +323,50 @@ (set-byte 3)) buf)) +(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))) + (macrolet ((set-byte (n) + `(setf (elt buf ,n) + (logand #xff (ash i ,(* 8 (- n 7))))))) + (set-byte 0) + (set-byte 1) + (set-byte 2) + (set-byte 3) + (set-byte 4) + (set-byte 5) + (set-byte 6) + (set-byte 7)) + buf)) + +(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)))) + i)) + +(defun decode-int64 (s) + "8 byte -> 64 bit int -> two's compliment (in network byte order)" + (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)))) + (if (>= i #x7fffffffffffffff) + (- 0 (- #x10000000000000000 i)) + i))) + ;; osc-strings are unsigned bytes, padded to a 4 byte boundary (defun decode-string (data) -- 2.39.5 From 3bde47386a67befa63da4280954af28c51e21a14 Mon Sep 17 00:00:00 2001 From: ErikR Date: Tue, 25 Aug 2015 21:59:32 +0200 Subject: [PATCH 26/27] Cleaning --- osc.lisp | 52 ++++++++++++++++++++++++++-------------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/osc.lisp b/osc.lisp index 4fb690f..cdce438 100644 --- a/osc.lisp +++ b/osc.lisp @@ -180,38 +180,38 @@ (let ((div (position 0 data))) (let ((tags (subseq data 1 div)) - (acc (subseq data (padded-length div))) - (result '())) + (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 #\h)) - (push (decode-uint64 (subseq acc 0 8)) - result) - (setf acc (subseq acc 8))) - ((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))) + #'(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 #\h)) + (push (decode-uint64 (subseq acc 0 8)) + result) + (setf acc (subseq acc 8))) + ((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))) (bl (+ 4 size)) (end (+ bl (mod (- 4 bl) 4)))) ; NOTE: cannot use (padded-length bl), as it is not the same algorithm. Blobs of 4, 8, 12 etc bytes should not be padded! (push (decode-blob (subseq acc 0 end)) result) (setf acc (subseq acc end)))) - (t (error "unrecognised typetag ~a" x)))) - tags) + (t (error "unrecognised typetag ~a" x)))) + tags) (nreverse result)))) -- 2.39.5 From 79d25ca4e0a4a04135b6bc56231c6b9bb058f1d4 Mon Sep 17 00:00:00 2001 From: Jamie Forth Date: Wed, 14 Oct 2015 14:21:30 +0100 Subject: [PATCH 27/27] export some more user-convenience functions --- package.lisp | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/package.lisp b/package.lisp index 8fc0e04..6bb6233 100644 --- a/package.lisp +++ b/package.lisp @@ -6,6 +6,7 @@ #:message #:make-bundle #:bundle + #:format-osc-data #:command #:args #:timetag @@ -46,10 +47,13 @@ #:make-osc-transmitter ; transmitters #:connect #:send + #:send-msg #:send-bundle #:send-to + #:send-msg-to #:send-bundle-to #:send-all + #:send-msg-all #:send-bundle-all #:make-osc-client ; clients #:make-client-responders -- 2.39.5