Update ci.yaml

and again...

.github/workflows/ci.yaml

@@ -1,36 +1,27 @@
 name: CI
 
 # details & description at http://3bb.cc/blog/2020/09/11/github-ci/
-# and/or https://github.com/roswell/roswell/wiki/GitHub-Actions
 
 # Controls when the action will run. Triggers the workflow on push for any branch, and
 # pull requests to master
 on:
   push:
   pull_request:
-    branches: [ endless, core ]
+    branches: [ endless ]
+
 
 # A workflow run is made up of one or more jobs that can run sequentially or in parallel
 jobs:
   test:
     name: ${{ matrix.lisp }} on ${{ matrix.os }}
+    continue-on-error: true
     strategy:
       matrix:
       # current ccl-bin has a flaky zip file, so roswell can't install it.
-      # Specify a version that works for now.
-        lisp: [ sbcl, ccl-bin, ecl ]
-        os: [ windows-latest, ubuntu-latest, macos-latest ]
-        include: 
-          - os: ubuntu-latest
-            lisp: allegro
-          - os: windows-latest
-            lisp: sbcl-bin
-        exclude: 
-          - os: windows-latest
-            lisp: ecl
-          - os: windows-latest
-            lisp: sbcl
-              
+      # Specify a version that works for now. #- cmucl, allegro, ccl, ecl, clisp
+        lisp: [sbcl-bin, ccl, ecl, allegro, clisp]
+        os: [ubuntu-latest, macos-latest, windows-latest]
+
     # run the job on every combination of "lisp" and "os" above
     runs-on: ${{ matrix.os }}
 
@@ -63,11 +54,11 @@ jobs:
         echo "$HOME/ros/bin" >> $GITHUB_PATH
 
     # Check out your repository under $GITHUB_WORKSPACE, so your job can access it
-    - uses: actions/checkout@v4
+    - uses: actions/checkout@v2
 
     - name: cache .roswell
       id: cache-dot-roswell
-      uses: actions/cache@v3
+      uses: actions/cache@v1
       with:
         path: ~/.roswell
         key: ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-${{ hashFiles('**/*.asd') }}
@@ -86,11 +77,10 @@ jobs:
       run: |
         ros -e '(format t "~a:~a on ~a~%...~%~%" (lisp-implementation-type) (lisp-implementation-version) (machine-type))'
         ros -e '(format t " fixnum bits:~a~%" (integer-length most-positive-fixnum))'
-        ros -e "(ql:quickload 'fiveam)"
         ros -e "(ql:quickload 'trivial-features)" -e '(format t "features = ~s~%" *features*)'
     - name: update ql dist if we have one cached
       run: ros -e "(ql:update-all-dists :prompt nil)"
 
     - name: load code and run tests
       run: |
-        ros -e '(handler-bind (#+asdf3.2(asdf:bad-SYSTEM-NAME (function MUFFLE-WARNING))) (handler-case (ql:quickload :osc) (error (a) (format t "caught error ~s~%~a~%" a a) (uiop:quit 123))))' -e '(asdf:test-system :osc)'
+        ros -e '(handler-bind (#+asdf3.2(asdf:bad-SYSTEM-NAME (function MUFFLE-WARNING))) (handler-case (ql:quickload :osc) (error (a) (format t "caught error ~s~%~a~%" a a) (uiop:quit 123))))' -e '(osc:run-tests)'

CHANGES

@@ -0,0 +1,54 @@
+ 2022-08-26
+    - version 0.7
+    - relicensing LLGPL → GPLv3
+ 2022-08-22
+    - version 0.6
+    - further improvements from jamieforth
+ 2019-04-02
+    - encoder/decoder refactoring from Javier Olaechea @PuercoPop
+ 2017-12-10
+    - osc-examples converted to usocket for portability from @boqs
+ 2015-08-25
+    - support for 64bit ints from Erik Ronström https://github.com/erikronstrom
+ 2015-08-21
+    - implement nested bundles from jamieforth https://github.com/jamieforth
+ 2011-04-19
+    - converted repo from darcs->git
+ 2010-09-25
+    - add osc-devices API from jamieforth
+ 2010-09-10
+    - timetag improvements from jamieforth https://github.com/jamieforth/osc
+ 2007-02-20
+    - version 0.5
+    - Allegro CL float en/decoding from vincent akkermans vincent.akkermans@gmail.com
+ 2006-02-11
+    - version 0.4
+    - partial timetag implementation
+ 2005-12-05
+    - version 0.3
+    - fixed openmcl float bug (decode-uint32)
+ 2005-11-29
+    - version 0.2
+    - openmcl float en/decoding
+ 2005-08-12
+    - corrections from Matthew Kennedy mkennedy@gentoo.org
+ 2005-08-11
+    - version 0.1
+ 2005-03-16
+    - packaged as an asdf installable lump
+ 2005-03-11
+    - bundle and blob en/de- coding
+ 2005-03-05
+    - 'declare' scattering and other optimisations
+ 2005-02-08
+    - in-package'd
+    - basic dispatcher
+ 2005-03-01
+    - fixed address string bug
+ 2005-01-26
+    - fixed string handling bug
+ 2005-01-24
+    - sends and receives multiple arguments
+    - tests in osc-tests.lisp
+ 2004-12-18
+    - initial version, single args only

README.md

@@ -0,0 +1,36 @@
+# 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 https://opensoundcontrol.org/
+
+
+## installation & usage
+
+the current version of this code is avilable from github
+
+`git clone https://github.com/zzkt/osc`
+
+or via quicklisp.. .
+
+`(ql:quickload "osc")`
+
+There are some basic examples in `osc-examples.lisp` and the `devices/examples/osc-device-examples.lisp` file shows how to use a higher-level API for sending and receiving OSC messages.
+
+## limitations
+
+  - will raise an exception if input is malformed
+  - no pattern matching on addresses
+  - float en/decoding only tested on sbcl, cmucl, openmcl and allegro
+  - the `devices` module only works on sbcl
+  - only supports the type(tag)s specified in the OSC spec
+
+## things to do in :osc
+
+  - address patterns using pcre
+  - data checking and error handling
+  - portable en/decoding of floats -=> ieee754 tests
+  - doubles and other defacto typetags
+
+## things to do in :osc-ex[tensions|tras]
+
+  - liblo like network wrapping (and devices)
+  - add namespace exploration using cl-zeroconf (or similar)

README.org

@@ -1,45 +0,0 @@
-# -*- mode: org;  coding: utf-8; -*-
-#+title: Open Sound Control
-
-This is a lisp implementation of the Open Sound Control protocol (or more accurately  “data transport specification” or “encoding”). The code should be close to ANSI standard common lisp and provides self contained code for encoding and decoding of OSC data, messages, and bundles. Since OSC describes a transport independent encoding (and does not specify a transport layer) messages can be send using TCP,  UDP or other network protocols (e.g. [[https://www.rfc-editor.org/rfc/rfc2549][RFC 2549]]). It seems UDP is more common amongst  programmes that communicate using OSC and. the =osc-examples.lisp= file contains a few simple examples of how to send and receive OSC via UDP. The examples are reasonably compatible with the packets send from/to max-msp, pd, supercollider and liblo. more details about OSC can be found at https://OpenSoundControl.org
-
-The current version of this code is available from github
-
-#+BEGIN_SRC shell
-git clone https://github.com/zzkt/osc
-#+END_SRC
-
-or via quicklisp.. .
-
-#+BEGIN_SRC lisp
-(ql:quickload "osc")
-#+END_SRC
-
-** OSC 1.0 and 1.1 support
-
-This implementation supports the [[https://opensoundcontrol.stanford.edu/spec-1_0.html][OpenSoundControl Specification 1.0]] and the required typetags listed in the [[https://opensoundcontrol.stanford.edu/spec-1_1.html][OpenSoundControl Specification 1.1]] (as described in an [[https://opensoundcontrol.stanford.edu/files/2009-NIME-OSC-1.1.pdf][NIME 2009 paper]] ). Some optional types are supported.
-
-| *Type tag* | *type*        | *description*                                                                                 | *v1.0* | *v1.1* | *cl-osc* |
-| i        | int32       | 32-bit big-endian two’s complement integer                                                  | *R*    | *R*    | YES    |
-| f        | float32     | 32-bit big-endian IEEE 754 floating point number                                            | *R*    | *R*    | YES    |
-| s        | OSC-string  | A sequence of non-null ASCII characters followed by a null…                                 |      | *R*    |        |
-|          |             | followed by 0-3 additional null characters. Total bits is a multiple of 32.                 | *R*    | N    | YES    |
-| b        | OSC-blob    | An int32 size count, followed by that many 8-bit bytes of arbitrary binary data…            |      | *R*    |        |
-|          |             | followed by 0-3 additional zero bytes. Total bits is a multiple of 32.                      | *R*    | N    | YES    |
-| T        | True        | No bytes are allocated in the argument data.                                                | O    | *R*    |        |
-| F        | False       | No bytes are allocated in the argument data.                                                | O    | *R*    |        |
-| N        | Null        | (aka nil, None, etc). No bytes are allocated in the argument data.                          | O    | *R*    |        |
-| I        | Impulse     | (aka “bang”), used for event triggers. No bytes are allocated in the argument data.         | O    | *R*    |        |
-| t        | OSC-timetag | an OSC timetag in NTP format, encoded in the data section                                   | O    | *R*    |        |
-| h        | int64       | 64 bit big-endian two’s complement integer                                                  | O    | O    | YES    |
-| d        | float64     | 64 bit (“double”) IEEE 754 floating point number                                            | O    | O    | YES    |
-| S        | OSC-string  | Alternate type represented as an OSC-string (e.g to differentiate “symbols” from “strings”) | O    | O    | YES    |
-| c        |             | an ascii character, sent as 32 bits                                                         | O    | O    |        |
-| r        |             | 32 bit RGBA color                                                                           | O    | O    |        |
-| m        |             | 4 byte MIDI message. Bytes from MSB to LSB are: port id, status byte, data1, data2          | O    | O    |        |
-| [        |             | Indicates the beginning of an array. The tags following are for data in the Array.          | O    | O    | YES?   |
-| ]        |             | Indicates the end of an array.                                                              | O    | O    | YES?   |
-
-
-- Required, Optional and Not supported (or Not required).
-- data is encoded as =(vector (unsigned 8))= by =cl-osc=

devices/client.lisp

@@ -0,0 +1,87 @@
+(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 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 bundle)
+    (format t "Server ~A has quit~%"
+            (make-addr+port-string address port))))
+
+(defgeneric register (client)
+  (:method ((client osc-client-udp))
+    (send-msg client "/cl-osc/register" (port client))))
+
+(defmethod osc-device-cleanup ((device osc-client-udp))
+  (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)
+  (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 (data timetag)
+                      (decode-bundle buffer :end length)
+                    (when (debug-mode receiver)
+                      (print-osc-debug-msg receiver data length
+                                           (peer-address receiver)
+                                           (peer-port receiver) timetag))
+                    (dispatch (address-tree receiver) data receiver
+                              address port))))
+       (osc-device-cleanup receiver)))
+   :name (format nil "osc-client-tcp-connection: ~A~%"
+                 (name receiver))))

devices/device.lisp

@@ -0,0 +1,129 @@
+(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)))
+
+(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)
+      (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))))

devices/dispatching-device.lisp

@@ -0,0 +1,39 @@
+(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 (data timetag)
+                      (osc:decode-bundle buffer :end length)
+                    (when (debug-mode receiver)
+                      (print-osc-debug-msg receiver data length
+                                           address port timetag))
+                    (dispatch (address-tree receiver) data receiver
+                              address port))))
+       (osc-device-cleanup receiver)))
+   :name (format nil "osc-receiver-udp: ~A~%" (name receiver))))
+
+
+;;;=====================================================================
+;;; OSC Responders
+;;;=====================================================================
+
+(defmacro add-osc-responder (dispatcher cmd-name
+                             (cmd args device address port timetag bundle)
+                             &body body)
+  `(dp-register (address-tree ,dispatcher) ,cmd-name
+                (lambda (,cmd ,args ,device ,address ,port ,timetag
+                         ,bundle)
+                  (declare (ignorable ,cmd ,args ,device ,address
+                                      ,port ,timetag ,bundle))
+                  ,@body)))
+
+(defgeneric remove-osc-responder (dispatcher address)
+  (:method ((dispatcher dispatching-device) address)
+    (dp-remove (address-tree dispatcher) address)))

devices/examples/osc-device-examples.lisp

@@ -0,0 +1,294 @@
+(cl:in-package #:osc)
+
+(ql:quickload "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-msg *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)
+
+;; 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* (message "/foo" 1 2 3))
+
+(send *osc-transmitter* (bundle :now
+                                (message "/foo" 1 2 3)))
+
+(let ((bundle
+       (bundle :now
+               (message "/foo" '(1 2 3))
+               (bundle :now
+                       (bundle :now
+                               (message "/bar"
+                                        '(10 20 30)))))))
+  (send *osc-transmitter* bundle))
+
+(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-msg *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-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-msg-to-client *osc-server* (make-name-string *osc-client*)
+                    "/bar" 2 99)
+
+(register *osc-client*)
+
+(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*)
+                       :time "/bar" 2 99)
+
+(add-osc-responder *osc-server* "/echo-sum"
+    (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 dev addr port timetag bundle)
+  (format t "Sum is ~a~%" (car args)))
+
+(send-msg *osc-client* "/echo-sum" 1 2 3 4)
+
+(add-osc-responder *osc-server* "/timetag+1"
+    (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-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*)
+
+
+;;;=====================================================================
+;;; 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-msg *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
+                             :debug-mode t))
+
+(connect *osc-client2* 57127
+         :host-address "127.0.0.1"
+         :port 57666) ; choose local port
+
+(device-socket-name *osc-client2*)
+
+(send-msg *osc-client2* "/bar" 4 5 6 9)
+
+(print-clients *osc-server*)
+
+(add-osc-responder *osc-server* "/print-sum"
+    (cmd args dev addr port timetag bundle)
+  (format t "Sum = ~A~%" (apply #'+ args)))
+
+(send-msg *osc-client2* "/print-sum" 4 5 6 9)
+
+(add-osc-responder *osc-server* "/echo-sum"
+    (cmd args dev addr port timetag bundle)
+  (send-msg dev cmd (apply #'+ args)))
+
+(send-msg *osc-client2* "/echo-sum" 4 5 6 9)
+
+(send-msg-all *osc-server* "/bar" 1 2 3) ; send to all peers
+
+(add-osc-responder *osc-server* "/echo-sum-all"
+    (cmd args dev addr port timetag bundle)
+  (send-msg-all dev cmd (apply #'+ args)))
+
+; Send to all peers (including self).
+(send-msg *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-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 dev addr port timetag bundle)
+  (send-msg dev 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-msg *osc-client* "/s_new" "default" 1001 0 0 "freq" 500)
+
+(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-msg *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.

devices/listening-device.lisp

@@ -0,0 +1,31 @@
+(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 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))
+          #\Tab #\Tab)
+  (format-osc-data data :stream stream)
+  (format stream "~%"))

devices/server.lisp

@@ -0,0 +1,224 @@
+(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
+                         :socket-buffer (make-socket-buffer 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 bundle)
+    (let ((listening-port (car args))) ; Optional port for sending
+                                       ; 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 bundle)
+    (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-msg-to-client server client-name "/cl-osc/server/registered"))
+
+(defun notify-quit (server client-name)
+  (send-msg-to-client server client-name "/cl-osc/server/quit"))
+
+
+;;;=====================================================================
+;;; TCP server functions
+;;;=====================================================================
+
+(defun register-tcp-client (server transmitter)
+  (setf (gethash (make-peername-string transmitter)
+		 (clients server))
+	transmitter))
+
+(defun unregister-tcp-client (server transmitter)
+  (remhash (make-peername-string 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
+;;;=====================================================================
+
+;; 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
+                 (call-next-method server client data)
+                 (warn "No client called ~A~%" client-name)))))
+
+(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 data)
+  (send client data))
+
+(defgeneric send-msg-to-client (server client-name command &rest args)
+  (:method ((server osc-server) client-name command &rest 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 (bundle timetag
+                          (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 (make-message command args)))
+      (send-all server message)))
+  (:method ((client-endpoint osc-client-endpoint) command &rest 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 (bundle timetag
+                          (make-message command args))))
+      (send-all server bundle)))
+  (:method ((client-endpoint osc-client-endpoint) timetag command
+            &rest args)
+    (let ((bundle (bundle timetag
+                          (make-message command args))))
+      (send-all client-endpoint bundle))))

devices/socket-functions.lisp

@@ -0,0 +1,84 @@
+(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 (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)
+    (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 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 active.")))
+
+(defun device-socket-peername (osc-device)
+  (socket-peername (socket osc-device)))
+
+(defun peer-port (osc-device)
+  (if (device-active-p osc-device)
+      (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)
+      (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.")))

devices/transmitter.lisp

@@ -0,0 +1,99 @@
+(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))))
+          (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)
+
+(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 data)
+  (:method ((transmitter osc-transmitter) data)
+    (let ((bytes (encode-osc-data data)))
+      (osc-write-to-stream
+          (slot-value (socket transmitter) 'stream) bytes))))
+
+(defgeneric send-msg (transmitter command &rest args)
+  (:method ((transmitter osc-transmitter) command &rest 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 (bundle timetag
+                          (make-message command args))))
+      (send transmitter bundle))))
+
+;; Unconnected sending (UDP only)
+
+(defgeneric send-to (transmitter address port data)
+  (:method ((transmitter osc-transmitter-udp) address port data)
+    (socket-send (socket transmitter)
+                 (encode-osc-data data) 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 (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 (bundle timetag
+                          (make-message command args))))
+      (send-to transmitter address port bundle))))

osc-data.lisp

@@ -0,0 +1,66 @@
+(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 args)
+  (unless (listp args)
+    (setf args (list args)))
+  (make-instance 'message
+                 :command command
+                 :args args))
+
+(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)
+                                                (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~%"
+            (command message)
+            args-string)))
+
+(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 stream :width width))
+  (format stream "~&]~%"))

osc-dispatch.lisp

@@ -1,14 +1,14 @@
 ;; -*- mode: lisp -*-
 ;;
-;; patern matching and dispatching for OSC messages 
+;; patern matching and dispatching for OSC messages
 ;;
 ;; 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)
 ;;
 
@@ -17,15 +17,15 @@
 
 ;; requirements
 ;;  - not too useful without osc
-;;  - probably cl-pcre for matching (when it happens). 
+;;  - probably cl-pcre for matching (when it happens).
 
 ;; commentary
 ;;  an osc de-/re -mungulator which should deal with piping data
 ;;  from incoming messages to the function/handler/method
-;;  designated by the osc-address. 
+;;  designated by the osc-address.
 ;;
 ;;  NOTE: only does direct matches for now, no pattern globs,
-;;        with single function per uri     
+;;        with single function per uri
 
 ;; changes
 ;;  2005-02-27 18:31:01
@@ -42,31 +42,46 @@
 
 ;;; ;; ;;;;;;  ;        ;  ;  ;
 ;;
-;; register/delete and dispatch. .. 
-;; 
-;;;;  ; ; ;   ;; 
+;; register/delete and dispatch. ..
+;;
+;;;;  ; ; ;   ;;
 
 (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))
+        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)
-  "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)
-        (apply #'x (cdr osc-message))))))
+        (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)))

osc-examples.lisp

@@ -5,7 +5,7 @@
 ;; Copyright (C) 2004 FoAM vzw
 ;;
 ;; Authors
-;;  - nik gaffney <nik@f0.am>
+;;  - nik gaffney <nik@fo.am>
 ;;
 ;;;;; ;; ;     ;    ;;    ;             ;
 
@@ -14,18 +14,19 @@
 ;; Commentry
 ;;
 ;;  These examples are currently sbcl specific, but should be easily ported to
-;;  work with trivial-sockets, acl-compat or something similar. They should be
-;;  able to explain enough to get you started. ..
+;;  work with trivial-sockets, acl-compat or something similar.
+;;  They should be enough to get you started.
 ;;
-;;  eg. listen on port 6667 for incoming msgs
+;;  eg. listen on port 6667 for incoming messages
 ;;
 ;;   (osc-receive-test 6667)
-;;  eg. send a test message to localhost port 6668
+;;
+;;  send a test message to localhost port 6668
 ;;
 ;;   (osc-send-test #(127 0 0 1) 6668)
 ;;
-;;  eg. listen on port 6667 and send to 10.0.89:6668
-;;     note the ip# is formatted as a vector
+;;  listen on port 6667 and send to 10.0.89:6668
+;;                     (note the ip# is formatted as a vector)
 ;;
 ;;   (osc-reflector-test 6667 #(10 0 0 89) 6668)
 ;;
@@ -41,52 +42,53 @@
   "a basic test function which attempts to decode an osc message on given port.
   note ip#s need to be in the format #(127 0 0 1) for now.. ."
   (let ((s (socket-connect nil nil
-			   :local-port port
-			   :local-host #(127 0 0 1)
-			   :protocol :datagram
-			   :element-type '(unsigned-byte 8)))
-	(buffer (make-sequence '(vector (unsigned-byte 8)) 1024)))
+                           :local-port port
+                           :local-host #(127 0 0 1)
+                           :protocol :datagram
+                           :element-type '(unsigned-byte 8)))
+        (buffer (make-sequence '(vector (unsigned-byte 8)) 1024)))
     (format t "listening on localhost port ~A~%~%" port)
     (unwind-protect
-	 (loop do
-	      (socket-receive s buffer (length buffer))
-	      (format t "received -=> ~S~%" (osc:decode-bundle buffer)))
+         (loop do
+               (socket-receive s buffer (length buffer))
+               (format t "received -=> ~S~%" (osc:decode-bundle buffer)))
       (when s (socket-close s)))))
 
+
 (defun osc-send-test (host port)
   "a basic test function which sends osc test message to a given port/hostname.
   note ip#s need to be in the format #(127 0 0 1) for now.. ."
   (let ((s (socket-connect host port
-			   :protocol :datagram
-			   :element-type '(unsigned-byte 8)))
-	(b (osc:encode-message "/foo/bar" "baz" 1 2 3 (coerce PI 'single-float))))
+                           :protocol :datagram
+                           :element-type '(unsigned-byte 8)))
+        (b (osc:encode-message "/foo/bar" "baz" 1 2 3 (coerce PI 'single-float))))
     (format t "sending to ~a on port ~A~%~%" host port)
     (unwind-protect
-	 (socket-send s b (length b))
+         (socket-send s b (length b))
       (when s (socket-close s)))))
 
+
 (defun osc-reflector-test (listen-port send-host 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.. ."
+  "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 (socket-connect nil nil
-			    :local-port listen-port
-			    :local-host #(127 0 0 1)
-			    :protocol :datagram
-			    :element-type '(unsigned-byte 8)))
-	(out (socket-connect send-host send-port
-			     :protocol :datagram
-			     :element-type '(unsigned-byte 8)))
-	(buffer (make-sequence '(vector (unsigned-byte 8)) 1024)))
+                            :local-port listen-port
+                            :protocol :datagram
+                            :element-type '(unsigned-byte 8)))
+        (out (socket-connect send-host send-port
+                             :protocol :datagram
+                             :element-type '(unsigned-byte 8)))
+        (buffer (make-sequence '(vector (unsigned-byte 8)) 1024)))
     (unwind-protect
-	 (loop do
-	      (socket-receive in buffer (length buffer))
-	      (format t "glonked -=> message: ~{~A, ~}~%"
-		      (osc:decode-bundle buffer))
-	      (let ((mess (apply #'osc:encode-message
-				 (cons "/echo"
-				       (osc:decode-message buffer)))))
-		(socket-send out mess (length mess))))
+         (loop do
+               (socket-receive in buffer (length buffer))
+               (format t "glonked -=> message: ~{~A, ~}~%"
+                       (osc:decode-bundle buffer))
+               (let ((mess (apply #'osc:encode-message
+                                  (cons "/echo"
+                                        (osc:decode-message buffer)))))
+                 (socket-send out mess (length mess))))
       (when in (socket-close in))
       (when out (socket-close out)))))
 
-;end
+;;end

osc-tests.lisp

@@ -1,370 +1,199 @@
 ;; -*- mode: lisp -*-
 ;;
-;; Various tests for cl-osc using 5am
+;; Quick and dirty tests for cl-osc
 ;;
+;; You are granted the rights to distribute and use this software
+;; as governed by the terms of GNU Public License (aka the GPL)
+;; see the LICENCE file.
+
 ;; Authors
 ;;  - nik gaffney <nik@fo.am>
 
-(defpackage :osc/tests
-  (:use :cl :osc :fiveam))
+(in-package :osc)
 
-(in-package :osc/tests)
+#+sbcl (require 'sb-bsd-sockets)
 
-;; (in-package :osc)
-;; (require "fiveam")
+#+sbcl (defun osc-write ()
+  "a basic test function which sends various osc stuff on port 5555"
+  (let ((sock (sb-bsd-sockets::make-instance
+               'inet-socket
+               :type :datagram
+               :protocol :udp)))
+    (sb-bsd-sockets::socket-connect sock #(127 0 0 1) 5555)
+    (let ((stream
+            (sb-bsd-sockets::socket-make-stream
+             sock
+             :input t
+             :output t
+             :element-type '(unsigned-byte 8)
+             :buffering :full)))
+      (prin1 "int? ")
+      (write-sequence (oti) stream)
+      (force-output stream)
+      (prin1 "float? ")
+      (write-sequence (otf) stream)
+      (force-output stream)
+      (prin1 "string?")
+      (write-sequence (ots) stream)
+      (force-output stream)
+      (prin1 "mutliple args?")
+      (write-sequence (otm) stream)
+      (force-output stream)
+      (sb-bsd-sockets::socket-close sock)
+      )))
 
-;; setup various test suites
-
-(def-suite synchroscope
-  :description "OSC test suite(s).")
-
-(def-suite data-encoding
-  :description "Test encoding and decoding of OSC data types."  :in synchroscope)
-
-(def-suite message-encoding
-  :description "Test encoding and decoding of OSC messages."  :in synchroscope)
-
-(def-suite protocol-v1.0
-  :description "OSC v1.0 compatibility."  :in synchroscope)
-
-(def-suite protocol-v1.1
-  :description "OSC v1.1 compatibility."  :in synchroscope)
-
-(def-suite interoperability
-  :description "Test interoperability (e.g. supercollider & pd)"  :in synchroscope)
+(defun oti () (osc:encode-message "/test/int" 3))
+(defun otf () (osc:encode-message "/test/float" 4.337))
+(defun ots () (osc:encode-message "/test/string" "wonky_stringpuk"))
+(defun otbl () (osc:encode-message "/test/blob" #(0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
+(defun otm ()  (osc:encode-message "/test/multi 5.78 1" "five point seven eight" "and one"))
+(defun otbn () (osc-encode-bundle (osc-make-test-bundle)))
 
 ;; test todo
-;;  - negative floats, NaN +/- Inf, etc
+;;  - negative floats
 ;;  - bignums
 ;;  - blobs, and long args
 ;;  - byte aligning 0,1,2,3,4 mod
 ;;  - error catching, junk data
-;;  - edge cases?
 
-(in-suite data-encoding)
+(defun osc-test ()
+  (format t "some osc tests: ~a"
+          (list
+           (osc-t2) (osc-t3) (osc-t4)
+           (osc-t5) (osc-t6) (osc-t7)
+           (osc-t8) (osc-t9) (osc-t10)
+           (osc-t11) (osc-t12) (osc-t13)))
+  T)
 
-(test osc-int32
-  "OSC int32 encoding tests."
-  (is (equalp
-       (osc::encode-int32 16843009) #(1 1 1 1)))
-  (is (equalp
-       (osc::decode-int32 #(127 255 255 255))
-       (osc::decode-uint32 #(127 255 255 255))))
-  (is (equalp
-       (osc::encode-int32 -16843010) #(254 254 254 254)))
-  (is (equalp
-       (osc::decode-int32 #(127 255 255 255)) #x7FFFFFFF))
-  (is (equalp
-       (osc::encode-int32 #xFFFFFFFF) #(255 255 255 255)))
-  (is (equalp
-       (osc::decode-int32 #(255 255 255 255)) -1))
-  (is (equalp
-       (osc::decode-uint32 #(255 255 255 255)) #xFFFFFFFF)))
+(defun osc-t2 ()
+  (equalp '("/dip/lop" 666)
+          (osc:decode-message #(47 100 105 112 47 108 111 112 0 0 0 0 44 105 0 0 0 0 2 154))))
 
-(test osc-string
-  "OSC string encoding tests."
-  (is (equalp
-       (osc::decode-string #(110 117 108 108 32 112 97 100 100 101 100 0))
-       "null padded"))
-  (is (equalp
-       (osc::encode-string "OSC string encoding test")
-       #(79  83 67  32  115 116 114 105 110 103 32  101
-         110 99 111 100 105 110 103 32  116 101 115 116 0 0 0 0))))
+(defun osc-t3 ()
+  (equalp '#(0 0 0 3 116 101 115 116 0 0 0 0 0 0 0 2 0 0 0 1 64 159 92 41)
+          (osc::encode-data '(3 "test" 2 1 4.98))))
 
-;; blob
-;;   (osc::encode-blob "THE BLOB")
+(defun osc-t4 ()
+  (equalp #(44 105 115 102 0 0 0 0)
+          (osc::encode-typetags '(1 "terrr" 3.4))))
 
-(test osc-blob
-  "OSC blob encoding tests."
-  (is (equalp
-       (osc::encode-blob #(1 1 1 1)) #(0 0 0 4 1 1 1 1))))
+(defun osc-t5 ()
+  (equalp #(44 105 105 102 0 0 0 0)
+          (osc::encode-typetags '(1 2 3.3))))
 
-(test osc-timetag
-  "OSC timetag encoding tests."
-  (is (equalp
-       (osc::encode-timetag :now) #(0 0 0 0 0 0 0 1))))
+(defun osc-t6 ()
+  (equal '("/test/one" 1 2 3.3)
+         (osc:decode-message #(47 116 101 115 116 47 111 110 101 0 0 0 44 105 105 102 0 0 0 0 0 0 0 1 0 0 0 2 64 83 51 51))))
 
-(test osc-int64
-  "OSC int64 encoding tests."
-  (is (equalp
-       (osc::encode-int64 16843009) #(0 0 0 0 1 1 1 1)))
-  (is (equalp
-       (osc::decode-int64 #(1 1 1 1 1 1 1 1)) 72340172838076673))
-  (is (equalp
-       (osc::encode-int64 -8000000000000000008) #(144 250 74 98 196 223 255 248)))
-  (is (equalp
-       (osc::decode-int64 #(254 1 254 1 254 1 254 1)) -143554428589179391)))
+(defun osc-t7 ()
+  (equalp '(#(0 0 0 0 0 0 0 1) ("/voices/0/tm/start" 0.0)
+            ("/foo/stringmessage" "a" "few" "strings") ("/documentation/all-messages"))
+          (osc:decode-bundle
+           #(#x23 #x62 #x75 #x6e
+             #x64 #x6c #x65 0
+             0    0    0    0
+             0    0    0    #x1
+             0    0    0    #x20
+             #x2f #x64 #x6f #x63
+             #x75 #x6d #x65 #x6e
+             #x74 #x61 #x74 #x69
+             #x6f #x6e #x2f #x61
+             #x6c #x6c #x2d #x6d
+             #x65 #x73 #x73 #x61
+             #x67 #x65 #x73 0
+             #x2c 0    0    0
+             0    0    0    #x2c
+             #x2f #x66 #x6f #x6f
+             #x2f #x73 #x74 #x72
+             #x69 #x6e #x67 #x6d
+             #x65 #x73 #x73 #x61
+             #x67 #x65 0    0
+             #x2c #x73 #x73 #x73
+             0    0    0    0
+             #x61 0    0    0
+             #x66 #x65 #x77 0
+             #x73 #x74 #x72 #x69
+             #x6e #x67 #x73 0
+             0    0    0    #x1c
+             #x2f #x76 #x6f #x69
+             #x63 #x65 #x73 #x2f
+             #x30 #x2f #x74 #x6d
+             #x2f #x73 #x74 #x61
+             #x72 #x74 0    0
+             #x2c #x66 0    0
+             0    0    0    0))))
+
+(defun osc-t8 ()
+  (equalp (osc:encode-message "/blob/x" #(1 2 3 4 5 6 7 8 9))
+          #(47 98 108 111 98 47 120 0 44 98 0 0 0 0 0 9 1 2 3 4 5 6 7 8 9 0 0 0)))
+
+(defun osc-t9 ()
+  (equalp '("/blob/x" #(1 2 3 4 5 6 7 8 9))
+          (osc:decode-message
+           #(47 98 108 111 98 47 120 0 44 98 0 0 0 0 0 9 1 2 3 4 5 6 7 8 9 0 0 0))))
+
+(defun osc-t10 ()
+  (equalp '("/t/x" #(1 29 32 43 54 66 78 81) 2 "lop")
+          (osc:decode-message
+            #(47 116 47 120 0 0 0 0 44 98 105 115 0 0 0 0 0 0 0 8 1 29 32 43 54
+              66 78 81 0 0 0 2 108 111 112 0))))
+
+(defun osc-t11 ()
+  (equalp '(#(0 0 0 0 0 0 0 1) ("/string/a/ling" "slink" "slonk" "slank")
+            ("/we/wo/w" 1 2 3.4) ("/blob" #(1 29 32 43 54 66 78 81 90) "lop" -0.44))
+          (osc:decode-bundle
+           #(35 98 117 110 100 108 101 0 0 0 0 0 0 0 0 1 0 0 0 40 47 98 108 111 98 0 0 0
+             44 98 115 102 0 0 0 0 0 0 0 9 1 29 32 43 54 66 78 81 90 0 0 0 108 111 112 0
+             190 225 71 174 0 0 0 32 47 119 101 47 119 111 47 119 0 0 0 0 44 105 105 102 0
+             0 0 0 0 0 0 1 0 0 0 2 64 89 153 154 0 0 0 48 47 115 116 114 105 110 103 47 97
+             47 108 105 110 103 0 0 44 115 115 115 0 0 0 0 115 108 105 110 107 0 0 0 115
+             108 111 110 107 0 0 0 115 108 97 110 107 0 0 0))))
 
 
-;; floating point tests
-;;  these tests cover only encoding and representation, not computation.
 
-(test osc-float32
-  "OSC float32 encoding tests."
-  (is (equalp
-       (osc::encode-float32 1.00001) #(63 128 0 84)))
-  (is (equalp
-       (osc::decode-float32  #(1 1 1 1)) 2.3694278s-38))
-  (is (equalp
-       (osc::encode-float32 -2.3694278s33) #(246 233 164 196)))
-  (is (equalp
-       (osc::decode-float32  #(254 255 255 255)) -1.7014117s38))
-  (is (equalp
-       (osc::decode-float32 #(127 255 255 255))
-       :NOT-A-NUMBER)))
+#+sbcl (defun osc-read (port)
+  "a basic test function which attempts to decode osc stuff on PORT."
+  (let ((s (make-instance 'inet-socket
+                          :type :datagram
+                          :protocol (get-protocol-by-name "udp")))
+        (buffer (make-sequence '(vector (unsigned-byte 8)) 512)))
+    (format t "Socket type is ~A on port ~A~%" (sockopt-type s) port)
+    (socket-bind s #(127 0 0 1) port)
+    (socket-receive s buffer nil :waitall t)
+    (socket-close s)
+    (osc:decode-message buffer)
+    ))
 
-(test osc-float64
-  "OSC float64 encoding tests."
-  (is (equalp
-       (osc::encode-float64 23.1d0) #(64 55 25 153 153 153 153 154)))
-  (is (equalp
-       (osc::decode-float64 #(64 55 25 153 153 153 153 154)) 23.1d0))
-  (is (equalp
-       (osc::decode-float64 #(1 1 1 1 1 1 1 1)) 7.748604185489348d-304))
-  (is (equalp
-       (osc::decode-float64 #(128 0 0 0 0 0 0 0)) -0.0d0))
-  (is (equalp
-       (osc::decode-float64 #(255 240 0 0 0 0 0 0))
-       :NEGATIVE-INFINITY))
-  (is (equalp
-       (osc::decode-float64 #(255 255 255 255 0 0 0 0))
-       :NOT-A-NUMBER)))
+;;(osc-decode-message data)
 
-;; #+sbcl (osc::decode-float32 #(127 255 255 255)) -> #<SINGLE-FLOAT quiet NaN>
-;; see also -> https://github.com/Shinmera/float-features/
-
-;; single-float
-
-(defun f32b (s) (write-to-string (osc::encode-float32 s ) :base 2))
-(defun f64b (s) (write-to-string (osc::encode-float64 s ) :base 2))
-
-(test single-float
-  "Various single floats of interest."
-  (is (equalp
-       (f32b 0.000000059604645s0) "#(110011 10000000 0 0)"))
-  (is (equalp
-       (f32b 0.000060975552s0) "#(111000 1111111 11000000 0)")))
-
-(test float-features
-  #+sbcl (pass
-          (format nil "SBCL floating point modes: ~A~%" (sb-int:get-floating-point-modes))))
-
-
-;; empty messages tagged T, F, N, I
-
-(in-suite message-encoding)
-
-;; messages
-
-(test osc-message-1
-  "OSC message encoding tests. address and single int."
-  :suite 'message-encoding
-  (is (equalp
-       '("/test/int" -1)
-       (osc:decode-message #(47 116 101 115 116 47 105 110 116 0 0 0 44 105 0 0 255 255 255 255)))))
-
-
-;; check padding boundaries. 1-3 or 1-4?
-(test osc-t4
-  "OSC typetag encoding test. string, ints and floats."
-  (is (equalp
-       #(44 105 115 102 0 0 0 0)
-       (osc::encode-typetags '(1 "terrr" 3.4)))))
-
-(test osc-t5
-  "OSC typetag encoding test. ints and floats."
-  (is (equalp
-       #(44 105 105 102 0 0 0 0)
-       (osc::encode-typetags '(1 2 3.3)))))
-
-(test osc-t6
-  "OSC message decoding test. ints and floats."
-  (is (equalp
-       '("/test/one" 1 2 3.3)
-       (osc:decode-message
-        #(47  116 101 115 116 47  111 110
-          101 0   0   0   44  105 105 102
-          0   0   0   0   0   0   0   1
-          0   0   0   2   64  83  51  51)))))
-
-(test osc-t7
-  "OSC bundle decoding test. strings, ints and floats."
-  (is (equalp
-       '(#(0 0 0 0 0 0 0 1)
-         ("/voices/0/tm/start" 0.0)
-         ("/foo/stringmessage" "a" "few" "strings")
-         ("/documentation/all-messages"))
-       (osc:decode-bundle
-        #(#x23 #x62 #x75 #x6e
-          #x64 #x6c #x65 0
-          0    0    0    0
-          0    0    0    #x1
-          0    0    0    #x20
-          #x2f #x64 #x6f #x63
-          #x75 #x6d #x65 #x6e
-          #x74 #x61 #x74 #x69
-          #x6f #x6e #x2f #x61
-          #x6c #x6c #x2d #x6d
-          #x65 #x73 #x73 #x61
-          #x67 #x65 #x73 0
-          #x2c 0    0    0
-          0    0    0    #x2c
-          #x2f #x66 #x6f #x6f
-          #x2f #x73 #x74 #x72
-          #x69 #x6e #x67 #x6d
-          #x65 #x73 #x73 #x61
-          #x67 #x65 0    0
-          #x2c #x73 #x73 #x73
-          0    0    0    0
-          #x61 0    0    0
-          #x66 #x65 #x77 0
-          #x73 #x74 #x72 #x69
-          #x6e #x67 #x73 0
-          0    0    0    #x1c
-          #x2f #x76 #x6f #x69
-          #x63 #x65 #x73 #x2f
-          #x30 #x2f #x74 #x6d
-          #x2f #x73 #x74 #x61
-          #x72 #x74 0    0
-          #x2c #x66 0    0
-          0    0    0    0)))))
-
-(test osc-t8
-  "OSC message encoding test. blob."
-  (is (equalp
-       (osc::encode-message "/blob/x" #(1 2 3 4 5 6 7 8 9))
-       #(47 98 108 111 98 47 120 0 44 98 0 0 0 0 0 9 1 2 3 4 5 6 7 8 9 0 0 0))))
-
-(test osc-t9
-  "OSC message decoding test. blob."
-  (is (equalp
-       '("/blob/x" #(1 2 3 4 5 6 7 8 9))
-       (osc::decode-message
-        #(47 98 108 111 98 47 120 0 44 98 0 0 0 0 0 9 1 2 3 4 5 6 7 8 9 0 0 0)))))
-
-(test osc-t10
-  "OSC message decoding test. blob, int, string."
-  (is (equalp '("/blob" #(1 29 32 43 54 66 78 81) "lop" 2)
-              (osc:decode-message
-               #(47 98 108 111 98 0 0 0 44 98 115 105 0 0 0
-                 0 0 0 0 8 1 29 32 43 54 66 78 81
-                 108 111 112 0 0 0 0 2)))))
-
-;; (test osc-t11
-;;   "OSC bundle decoding test."
-;;   (is (equalp
-;;        '(#(0 0 0 0 0 0 0 1)
-;;          ("/string/a/ling" "slink" "slonk" "slank")
-;;          ("/we/wo/w" 1 2 3.4)
-;;          ("/blob" #(1 29 32 43 54 66 78 81 90) "lop" -0.44))
-;;        (osc:decode-bundle
-;;         #(35 98 117 110 100 108 101 0 0 0 0 0 0 0 0 1 0 0 0 40 47 98 108 111 98 0 0 0
-;;           44 98 115 102 0 0 0 0 0 0 0 9 1 29 32 43 54 66 78 81 90 0 0 0 108 111 112 0
-;;           190 225 71 174 0 0 0 32 47 119 101 47 119 111 47 119 0 0 0 0 44 105 105 102 0
-;;           0 0 0 0 0 0 1 0 0 0 2 64 89 153 154 0 0 0 48 47 115 116 114 105 110 103 47 97
-;;           47 108 105 110 103 0 0 44 115 115 115 0 0 0 0 115 108 105 110 107 0 0 0 115
-;;           108 111 110 107 0 0 0 115 108 97 110 107 0 0 0)))))
+(defun osc-ft ()
+  (and (eql (osc::DECODE-FLOAT32 #(63 84 32 93))  0.8286188)
+       (eql (osc::DECODE-FLOAT32 #(190 124 183 78)) -0.246793)))
 
 
 ;; equalp but not eql
-(test osc-t13
-  "OSC message encoding test."
-  (is (equalp
-       (osc:encode-message "/asdasd" 3.6 4.5)
-       #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0))))
+(defun osc-t12 ()
+  (equalp (osc:encode-message "/asdasd" 3.6 4.5)
+          #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0)))
 
 ;; equal but not eql
-(test osc-t14
-  "OSC message decoding test."
-  (is (equalp
-       (osc:decode-message
-        #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0))
-       (list "/asdasd" 3.6 4.5))))
+(defun osc-t13 ()
+  (equal (osc:decode-message #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0))
+         (list "/asdasd" 3.6 4.5)))
 
-;; symmetrical?  how much of a issue is this?
-(test osc-recode
-  "OSC message encoding & decoding symmetry test."
-  (let ((message (osc:decode-message
-                  #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0))))
-    (is (equalp
-         message
-         (osc:decode-message
-          (apply #'osc:encode-message message))))))
+;; not symmetrical?  how much of a problem is this?
+(defun osc-asym-t1 ()
+  "this test will fail"
+  (osc:decode-message
+   (osc:encode-message
+    (osc:decode-message #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0)))))
 
-;; partially pathological string tests...
-(test osc-sp1
-  (is (equalp
-       (osc:encode-message "/s/t0" "four")
-       #(47 115 47 116 48 0 0 0 44 115 0 0 102 111 117 114 0 0 0 0)))
-  (is (equalp
-       (osc:decode-message #(47 115 47 116 48 0 0 0 44 115 0 0 102 111 117 114 0 0 0 0))
-       '("/s/t0" "four"))))
+(defun osc-asym-t2 ()
+  "testing the assumptions about representations of messages"
+  (setf packed-msg #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0))
+  (setf cons-msg (osc:decode-message packed-msg))
+  (osc:encode-message (values-list cons-msg)))
 
-(test osc-sp2
-  (is (equalp
-       (osc:encode-message "/s/t0" 2 "xxxxx" 3)
-       #(47 115 47 116 48 0 0 0 44 105 115 105 0 0 0 0
-         0 0 0 2 120 120 120 120 120 0 0 0 0 0 0 3)))
-  (is (equalp
-       (osc:decode-message
-        #(47 115 47 116 48 0 0 0 44 105 115 105 0 0 0 0
-          0 0 0 2 120 120 120 120 120 0 0 0 0 0 0 3))
-       '("/s/t0" 2 "xxxxx" 3))))
-
-;; (test osc-t16
-;;       "OSC message encoding & decoding symmetry test."
-;;  (let* ((packed-msg #(47 97 115 100 97 115 100 0 44 102 102 0 64 102 102 102 64 144 0 0))
-;;         (cons-msg (osc:decode-message packed-msg)))
-;;    (is (equalp
-;;         packed-msg
-;;         (osc:encode-message (values-list cons-msg))))))
-
-;; v1.0 tests
-(in-suite protocol-v1.0)
-
-(test v1.0-required-types
-  "OSC data encoding test. All required types for v1.0"
-  (is (equalp
-       #(0 0 0 3 116 101 115 116 0 0 0 0 67 82 0 0 0 0 0 4 1 2 3 4)
-       (osc::encode-data '(3 "test" 2.1e2 #(1 2 3 4))))))
-
-;; v1.1. tests
-(in-suite protocol-v1.1)
-
-(test v1.1-required-data-types
-  "OSC data encoding test. All required types for v1.1"
-  (is (equalp
-       #(44 105 104 115 102 100 98 0)
-       (osc::encode-typetags '(3
-                               4294967297
-                               "test"
-                               2.1e2
-                               2.1d23
-                               #(1 2 3 4)
-                               ;; (osc::encode-timetag :now)
-                               )))))
-
-(test v1.1-keyword-typetags
-  "OSC typetag encoding test."
-  (is (equalp
-       (osc::encode-typetags '(:true :false :null :impulse))
-       #(44 84 70 78 73 0 0 0))))
-
-;;  (osc::encode-typetags '("s" 1))
-
-
-;; play nicely with others
-(in-suite interoperability)
-
-(test hex-strings
-  "OSC data in hex."
-  (is (equalp
-       (osc::write-data-as-hex (osc::encode-string "hexadecimate"))
-       "#(68 65 78 61 64 65 63 69 6D 61 74 65 0 0 0 0)"))
-  (is (equalp
-       (osc::decode-string #(#x68 #x65 #x78 #x61 #x64 #x65 #x63 #x69
-                             #x6D #x61 #x74 #x65 #x0 #x0 #x0 #x0))
-       "hexadecimate")))
 
 #|
 sc3 server
@@ -383,4 +212,5 @@ sc3 server
 
 |#
 
-(run! 'synchroscope)
+(defun run-tests ()
+  (osc-test))

osc-time.lisp

@@ -0,0 +1,79 @@
+(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."
+  #+sbcl (multiple-value-bind (secs usecs)
+             (sb-ext:get-time-of-day)
+           (the timetag (unix-secs+usecs->timetag secs usecs)))
+  #-sbcl (error "Can't encode timetags using this implementation."))
+
+(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."
+  #+sbcl (multiple-value-bind (secs usecs)
+             (sb-ext:get-time-of-day)
+           (the double-float (+ secs (microseconds->subsecs usecs))))
+  #-sbcl (error "Can't encode timetags using this implementation."))
+
+(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)
+  (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))
+  (coerce (/ usecs  +usecs+) 'double-float))
+
+(defun subsecs->microseconds (subsecs)
+  (declare (type (float 0.0 1.0) 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)

osc.asd

@@ -1,19 +1,34 @@
 ;; -*- mode: lisp -*-
-(in-package :asdf-user)
 
-(defsystem "osc"
-  :description "The Open Sound Control protocol, aka OSC"
+(in-package #:cl-user)
+
+(asdf:defsystem osc
+  :name "osc"
   :author "nik gaffney <nik@fo.am>"
-  :depends-on ("ieee-floats")
-  :version "0.9.1"
   :licence "GPL v3"
-  :components ((:file "osc"))
-  :in-order-to ((test-op (test-op "osc/tests"))))
-
-;; regression testing. can be ignored/disabled at run time if required
-(defsystem "osc/tests"
-  :description "Tests for OSC library."
-  :depends-on ("osc" "fiveam")
-  :components ((:file "osc-tests"))
-  :perform (test-op (o c)
-                    (uiop:symbol-call :fiveam '#:run! :synchroscope)))
+  :description "The Open Sound Control protocol aka OSC"
+  :version "0.7"
+  :depends-on (:usocket)
+  :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 "osc-tests" :depends-on ("osc"))
+   (:file "package")
+   (:module "devices"
+    :if-feature :sbcl
+    :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"))))))

osc.lisp

@@ -1,51 +1,48 @@
 ;;; -*- mode: lisp -*-
 ;;;
-;;; An implementation of the OSC (Open Sound Control) protocol
+;;; an implementation of the OSC (Open Sound Control) protocol
 ;;;
-;;; Copyright (c) 2004 FoAM
+;;; copyright (C) 2004 FoAM vzw.
 ;;;
-;;; cl-osc is free software: you can redistribute it and/or modify it
-;;; under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation, either version 3 of the License, or
-;;; (at your option) any later version.
+;;; 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.
+;;; Where these conflict, the preamble takes precedence. The LLGPL
+;;; is available online at http://opensource.franz.com/preamble.html
+;;; and is distributed with this code (see: LICENCE and LGPL files)
 ;;;
-;;; Authors
+;;; authors
 ;;;
-;;;  nik gaffney <nik@fo.am> and the listed AUTHORS
+;;;  nik gaffney <nik@f0.am>
 ;;;
-;;; Requirements
+;;; requirements
 ;;;
-;;;  depends on ieee-floats for float encoding and 5am for testing
+;;;  dependent on sbcl, cmucl or openmcl for float encoding, other suggestions
+;;;  welcome.
 ;;;
-;;; Commentary
+;;; commentary
 ;;;
-;;;  This is an implementation of the OSC protocol which is used
-;;;  for communication mostly amongst music programs and their attached
-;;;  musicians (eg. supercollider, max/pd, ableton, etc).
+;;;  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 -=>
+;;;                     http://www.cnmat.berkeley.edu/OpenSoundControl/
 ;;;
-;;;  The OSC V1.0 is supported, and there is partial support for V1.1
-;;;  More details of the protocol can be found at
-;;;                     http://OpenSoundControl.org
-;;;
-;;;  see the README file for further details...
-;;;
-;;;  Known BUGS/Issues
-;;;   - encoding a :symbol that is unbound or without symbol-value causes an error
-;;;   - unknown types are sent as 'blobs' which may or may not be an issue
+;;;   - doesnt send nested bundles or timetags later than 'now'
 ;;;   - malformed input -> exception
-
-(defpackage :osc
-  (:use :cl)
-  (:shadow :ieee-floats)
-  (:documentation "OSC the 'Open Sound Control' protocol")
-  (:export
-   #:encode-message
-   #:encode-bundle
-   #:decode-message
-   #:decode-bundle))
+;;;   - 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
+;;;
+;;;  see the README file for more details...
+;;;
+;;; known BUGS
+;;;   - encoding a :symbol which is unbound, or has no symbol-value will cause
+;;;     an error
+;;;
 
 (in-package :osc)
-;; (declaim (optimize (speed 3) (safety 1) (debug 3)))
+
+;;(declaim (optimize (speed 3) (safety 1) (debug 3)))
 
 ;;;;;; ;    ;;    ;     ; ;     ; ; ;         ;
 ;;
@@ -53,88 +50,86 @@
 ;;
 ;;;; ;;  ;;   ; ; ;;           ;      ;  ;                  ;
 
-(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)
        (string-padding address)))
 
 (defun encode-typetags (data)
-  "Create a typetag string suitable for the given DATA.
-  valid typetags according to the OSC 1.0 spec are ,i ,f ,s and ,b
-  the OSC 1.1 spec includes ,h ,t ,d ,S ,T ,F ,N and ,I
+  "creates a typetag string suitable for the given data.
+  valid typetags according to the osc spec are ,i ,f ,s and ,b
+  non-std extensions include ,{h|t|d|S|c|r|m|T|F|N|I|[|]}
+                             see the spec for more details. ..
 
-  The following tags are written based on type check
-          integer => i => #(105)
-                  => h => #(104)
-     single-float => f => #(102)
-    double-float  => d => #(100)
-   simple-string  => s => #(115)
-                * => b => #(98)
+  NOTE: currently handles the following tags
+   i => #(105) => int32
+   f => #(102) => float
+   s => #(115) => string
+   b => #(98)  => blob
+   h => #(104) => int64
+  and considers non int/float/string data to be a blob."
 
- The following tags are written based on :keywords in the data
-   :true (or t) => T => #(84)
-        :false  => F => #(70)
-          :null => N => #(78)
-      :impulse  => I => #(73)
-"
   (let ((lump (make-array 0 :adjustable t
-                            :fill-pointer t)))
+                          :fill-pointer t)))
     (macrolet ((write-to-vector (char)
                  `(vector-push-extend
                    (char-code ,char) lump)))
-      (write-to-vector #\,) ;; #(44)
+      (write-to-vector #\,)
       (dolist (x data)
         (typecase x
           (integer (if (>= x 4294967296) (write-to-vector #\h) (write-to-vector #\i)))
-          (single-float (write-to-vector #\f))
-          (double-float (write-to-vector #\d))
+          (float (write-to-vector #\f))
           (simple-string (write-to-vector #\s))
-          ;; lisp semantics vs. OSC semantics
-          (keyword (case x
-                    (:true (write-to-vector #\T))
-                    (:false (write-to-vector #\F))
-                    (:null (write-to-vector #\N))
-                    (:impulse (write-to-vector #\I))))
-          (null (write-to-vector #\F))
-          ;; anything else is treated as a blob
+          (keyword (write-to-vector #\s))
           (t (write-to-vector #\b)))))
     (cat lump
          (pad (padding-length (length lump))))))
 
-(defun encode-data (data)
-  "Encode 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 (if (>= x 4294967296) (enc encode-int64) (enc encode-int32)))
-          (single-float (enc encode-float32))
-          (double-float (enc encode-float64))
+          (float (enc encode-float32))
           (simple-string (enc encode-string))
-          ;; -> timetag
           (t (enc encode-blob))))
       lump)))
 
@@ -145,33 +140,91 @@
 ;;
 ;;; ;;    ;;     ; ;     ;      ;      ; ;
 
-(defun decode-bundle (data)
-  "Decode an OSC bundle into a list of decoded-messages.
- The first element is an osc-timetag."
-  (let ((contents '()))
-    (if (equalp 35 (elt data 0)) ;; a bundle begins with '#'
-        (let ((timetag (subseq data 8 16))
-              (i 16)
-              (bundle-length (length data)))
-          (loop while (< i bundle-length)
-                do (let ((mark (+ i 4))
-                         (size (decode-int32
-                                (subseq data i (+ i 4)))))
-                     (if (eq size 0)
-                         (setf bundle-length 0)
-                         (push (decode-bundle
-                                (subseq data mark (+ mark size)))
-                               contents))
-                     (incf i (+ 4 size))))
-          (push timetag contents))
-        (decode-message data))))
+(defun 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
+preceding 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 (make-bundle timetag elements)
+                                timetag))))
+      ;; Message
+      (let ((message
+             (decode-message
+              (subseq buffer start (+ start end)))))
+        (make-message (car message) (cdr message)))))
 
 (defun decode-message (message)
-  "Reduce an OSC MESSAGE to an (address . data) pair."
+  "reduces an osc message to an (address . data) pair. .."
   (declare (type (vector *) message))
   (let ((x (position (char-code #\,) message)))
-    (if (eq x NIL)
-        (format t "Message contains no data.. ")
+    (if (eq x nil)
+        (format t "message contains no data.. ")
         (cons (decode-address (subseq message 0 x))
               (decode-taged-data (subseq message x))))))
 
@@ -181,10 +234,10 @@
           'string))
 
 (defun decode-taged-data (data)
-  "Decode DATA encoded with typetags.
+  "decodes data encoded with typetags...
   NOTE: currently handles the following tags
    i => #(105) => int32
-   f => #(102) => float32
+   f => #(102) => float
    s => #(115) => string
    b => #(98)  => blob
    h => #(104) => int64"
@@ -218,7 +271,8 @@
                   (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!
+                    ;; 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))))
@@ -226,54 +280,50 @@
            tags)
       (nreverse result))))
 
+
 ;;;;;; ;; ;; ; ; ;  ;  ; ;;     ;
 ;;
-;; Timetags
+;; 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 any 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)
-  "Encode 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 timetag of 1 will be interpreted as 'immediately'
-    ((equalp utime :now)
+    ((equalp timetag :now)
+     ;; a 1 bit timetag will be interpreted as 'immediately'
      #(0 0 0 0 0 0 0 1))
-    ;; converts seconds since 19000101 to seconds since 19700101
-    ;; note: fractions of seconds are accurate, but not synchronised.
-    ((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 :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)
-  "Decompose a TIMETAG into unix-time and 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)))
 
 ;;;;; ; ; ;;    ;; ; ;
 ;;
@@ -281,7 +331,26 @@
 ;;
 ;;; ;; ;   ;  ;
 
-;; integers. 32 and 64 bit. signed and unsigned.
+;; floats are encoded using implementation specific 'internals' which is not
+;; particulaly portable, but 'works for now'.
+
+(defun encode-float32 (f)
+  "encode an ieee754 float as a 4 byte vector. currently sbcl/cmucl specific"
+  #+sbcl (encode-int32 (sb-kernel:single-float-bits f))
+  #+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)))
+  #-(or sbcl cmucl openmcl allegro) (error "Can't encode floats using this implementation."))
+
+(defun decode-float32 (s)
+  "ieee754 float from a vector of 4 bytes in network byte order"
+  #+sbcl (sb-kernel:make-single-float (decode-int32 s))
+  #+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)))
+  #-(or sbcl cmucl openmcl allegro) (error "Can't decode floats using this implementation."))
 
 (defmacro defint-decoder (num-of-octets &optional docstring)
   (let ((decoder-name (intern (format nil "~:@(decode-uint~)~D" (* 8 num-of-octets))))
@@ -293,12 +362,18 @@
        (let* ((,int 0)
               ,@(loop
                   for n below num-of-octets
-                  collect `(,int
-                            (dpb (aref ,seq ,n)
-                                 (byte 8 (* 8 (- (1- ,num-of-octets) ,n)))
-                                 ,int))))
+                  collect `(,int (dpb (aref ,seq ,n) (byte 8 (* 8 (- (1- ,num-of-octets) ,n)))
+                                      ,int))))
          ,int))))
 
+(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))))
+    i))
+
 (defmacro defint-encoder (num-of-octets &optional docstring)
   (let ((enc-name (intern (format nil "~:@(encode-int~)~D" (* 8 num-of-octets))))
         (buf (gensym))
@@ -308,123 +383,79 @@
            (list docstring))
        (let ((,buf (make-array ,num-of-octets :element-type '(unsigned-byte 8))))
          ,@(loop
-             for n below num-of-octets
-             collect `(setf (aref ,buf ,n)
-                            (ldb (byte 8 (* 8 (- (1- ,num-of-octets) ,n)))
-                                 ,int)))
+                 for n below num-of-octets
+                 collect `(setf (aref ,buf ,n)
+                                (ldb (byte 8 (* 8 (- (1- ,num-of-octets) ,n)))
+                                     ,int)))
          ,buf))))
 
-;; generate functions decode-uint32 and decode-uint64
-(defint-decoder 4 "4 byte -> 32 bit unsigned int")
-(defint-decoder 8 "8 byte -> 64 bit unsigned int")
-
-;; generate functions encode-int32 and encode-int64
-(defint-encoder 4 "Convert an integer into a sequence of 4 bytes in network byte order.")
-(defint-encoder 8 "Convert an integer into a sequence of 8 bytes in network byte order.")
+(defint-encoder 4 "Convert an integer into a sequence of 4 bytes in network byte order (32 bit).")
+(defint-encoder 8 "Convert an integer into a sequence of 8 bytes in network byte order (64 bit).")
 
 (defun decode-int32 (s)
   "4 byte -> 32 bit int -> two's complement (in network byte order)"
   (let ((i (decode-uint32 s)))
-    (if (>= i (expt 2 31))
-        (- (- (expt 2 32) i))
+    (if (>= i #.(1- (expt 2 31)))
+        (- (- #.(expt 2 32) i))
         i)))
 
 (defun decode-int64 (s)
   "8 byte -> 64 bit int -> two's complement (in network byte order)"
   (let ((i (decode-uint64 s)))
-    (if (>= i (expt 2 63))
-        (- (- (expt 2 64) i))
+    (if (>= i #.(1- (expt 2 63)))
+        (- (- #.(expt 2 64) i))
         i)))
 
-;; floats are encoded using ieee-floats library for brevity and compatibility
-;; - https://ieee-floats.common-lisp.dev/
-;;
-;; It should be possible to use 32 and 64 bit floats in most common lisp environments.
-;; An implementation specific encoder/decoder can be used where available.
-
-(declaim (inline ieee-floats:encode-float32
-                 ieee-floats:decode-float32
-                 ieee-floats:encode-float64
-                 ieee-floats:decode-float64))
-
-(ieee-floats:make-float-converters ieee-floats:encode-float32
-                                   ieee-floats:decode-float32 8 23 t)
-
-(ieee-floats:make-float-converters ieee-floats:encode-float64
-                                   ieee-floats:decode-float64 11 52 t)
-
-(defun encode-float32 (f)
-  "Encode an ieee754 float as a 4 byte vector."
-  #+sbcl (encode-int32 (sb-kernel:single-float-bits f))
-  #-sbcl (encode-int32 (ieee-floats:encode-float32 f)))
-
-(defun decode-float32 (v)
-  "Convert a vector of 4 bytes in network byte order into an ieee754 float."
-  (ieee-floats:decode-float32 (decode-uint32 v)))
-
-(defun encode-float64 (d)
-  "Encode an ieee754 float as a 8 byte vector."
-  (encode-int64 (ieee-floats:encode-float64 d)))
-
-(defun decode-float64 (v)
-  "Convert a vector of 8 bytes in network byte order into an ieee754 float."
-  (ieee-floats:decode-float64 (decode-uint64 v)))
-
 ;; osc-strings are unsigned bytes, padded to a 4 byte boundary
 
-(defun decode-string (data)
-  "Convert a binary vector to a string and remove any trailing #\nul characters."
-  (string-trim '(#\nul) (coerce (map 'vector #'code-char data) 'string)))
-
 (defun encode-string (string)
-  "Encode a STRING as a vector of character-codes padded to 4 byte boundary."
+  "encodes a string as a vector of character-codes, padded to 4 byte boundary"
   (cat (map 'vector #'char-code string)
        (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
-;; padded to a 4 byte boundary.
+;; osc-padded to a 4 byte boundary.
+
+(defun encode-blob (blob)
+  "encodes a blob from a given vector"
+  (let ((bl (length blob)))
+    (cat (encode-int32 bl) blob
+         <<<<<<< HEAD
+         (pad (padding-length bl)))))
 
 (defun decode-blob (blob)
-  "Decode a BLOB as a vector of unsigned bytes."
+  "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)
-  "Encode BLOB as a vector."
-  (let ((bl (length blob)))
-    (cat (encode-int32 bl) blob
-         (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
-;; NOTE: string padding is treated differently between v1.0 and v1.1
-
-(defun write-data-as-hex (data)
-  "Write OSC data (represented as vector) as string in base 16."
- (write-to-string data :base 16))
+;; utility functions for osc-string/padding slonking
 
 (defun cat (&rest catatac)
-  "Concatenate items into a byte vector."
   (apply #'concatenate '(vector (unsigned-byte 8)) catatac))
 
 (defun padding-length (s)
-  "Return the length of padding required for a given length of string."
+  "returns the length of padding required for a given length of string"
   (declare (type fixnum s))
   (- 4 (mod s 4)))
 
 (defun padded-length (s)
-  "Return the length of an osc-string made from a given length of string."
+  "returns the length of an osc-string made from a given length of string"
   (declare (type fixnum s))
   (+ s (- 4 (mod s 4))))
 
 (defun string-padding (string)
-  "Return the padding required for a given osc string."
+  "returns the padding required for a given osc string"
   (declare (type simple-string string))
   (pad (padding-length (length string))))
 
 (defun pad (n)
-  "Make a sequence of the required number of #\Nul characters."
+  "make a sequence of the required number of #\Nul characters"
   (declare (type fixnum n))
   (make-array n :initial-element 0 :fill-pointer n))
 

package.lisp

@@ -0,0 +1,81 @@
+(defpackage :osc
+  (:use :cl)
+  (:documentation "OSC, the 'Open Sound Control' protocol.")
+  (:export
+   #:make-message
+   #:message
+   #:make-bundle
+   #:bundle
+   #:format-osc-data
+   #: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
+
+   #: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-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
+   #: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
+   #:run-tests))