[elpa] 01/01: Add osc.el.

[Mario Lang]

mlang pushed a commit to branch master
in repository elpa.

commit 7da6741f270fd2404f0d62b5ea3b1d70eb5f2898
Author: Mario Lang <address@hidden>
Date:   Sat May 24 04:01:52 2014 +0200

    Add osc.el.
---
 packages/osc/osc.el |  237 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 files changed, 237 insertions(+), 0 deletions(-)

diff --git a/packages/osc/osc.el b/packages/osc/osc.el
new file mode 100644
index 0000000..e214f8d
--- /dev/null
+++ b/packages/osc/osc.el
@@ -0,0 +1,237 @@
+;;; osc.el --- Open Sound Control protocol library
+
+;; Copyright (C) 2014  Free Software Foundation, Inc.
+
+;; Author: Mario Lang <address@hidden>
+;; Version: 0.1
+;; Keywords: comm, processes, multimedia
+
+;; This program 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.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; OpenSound Control ("OSC") is a protocol for communication among
+;; computers, sound synthesizers, and other multimedia devices that is
+;; optimized for modern networking technology and has been used in many
+;; application areas.
+
+;; This package implements low-level functionality for OSC clients and servers.
+;; In particular:
+;; * `osc-make-client' and `osc-make-server' can be used to create process 
objects.
+;; * `osc-send-message' encodes and sends OSC messages from a client process.
+;; * `osc-server-set-handler' can be used to change handlers for particular
+;;   OSC paths on a server process object on the fly.
+
+;; BUGS/TODO:
+;;
+;; * Timetags and binary blobs are not supported yet.
+
+;; Usage:
+;;
+;; Client: (setq my-client (osc-make-client "localhost" 7770))
+;;         (osc-send-message my-client "/osc/path" 1.5 1.0 5 "done")
+;;         (delete-process my-client)
+;;
+;; Server: (setq my-server (osc-make-server "localhost" 7770
+;;          (lambda (path &rest args)
+;;            (message "OSC %s: %S" path args))))
+
+;;; Code:
+
+(require 'cl-lib)
+
+(defun osc-insert-string (string)
+  (insert string 0 (make-string (- 3 (% (length string) 4)) 0)))
+
+(defun osc-insert-float32 (value)
+  (let (s (e 0) f)
+    (cond
+     ((string= (format "%f" value) (format "%f" -0.0))
+      (setq s 1 f 0))
+     ((string= (format "%f" value) (format "%f" 0.0))
+      (setq s 0 f 0))
+     ((= value 1.0e+INF)
+      (setq s 0 e 255 f (1- (expt 2 23))))
+     ((= value -1.0e+INF)
+      (setq s 1 e 255 f (1- (expt 2 23))))
+     ((string= (format "%f" value) (format "%f" 0.0e+NaN))
+      (setq s 0 e 255 f 1))
+     (t
+      (setq s (if (>= value 0.0)
+                 (progn (setq f value) 0)
+               (setq f (* -1 value)) 1))
+      (while (>= (* f (expt 2.0 e)) 2.0) (setq e (1- e)))
+      (if (= e 0) (while (< (* f (expt 2.0 e)) 1.0) (setq e (1+ e))))
+      (setq f (round (* (1- (* f (expt 2.0 e))) (expt 2 23)))
+           e (+ (* -1 e) 127))))
+    (insert (+ (lsh s 7) (lsh (logand e #XFE) -1))
+           (+ (lsh (logand e #X01) 7) (lsh (logand f #X7F0000) -16))
+           (lsh (logand f #XFF00) -8)
+           (logand f #XFF))))
+
+(defun osc-insert-int32 (value)
+  (let (bytes)
+    (dotimes (i 4)
+      (push (% value 256) bytes)
+      (setq value (/ value 256)))
+    (dolist (byte bytes)
+      (insert byte))))
+
+;;;###autoload
+(defun osc-make-client (host port)
+  "Create an OSC client process which talks to HOST and PORT."
+  (make-network-process
+   :name "OSCclient"
+   :coding 'binary
+   :host host
+   :service port
+   :type 'datagram))
+
+;;;###autoload
+(defun osc-send-message (client path &rest args)
+  "Send an OSC message from CLIENT to the specified PATH with ARGS."
+  (with-temp-buffer
+    (set-buffer-multibyte nil)
+    (osc-insert-string path)
+    (osc-insert-string
+     (apply 'concat "," (mapcar (lambda (arg)
+                                 (cond
+                                  ((floatp arg) "f")
+                                  ((integerp arg) "i")
+                                  ((stringp arg) "s")
+                                  (t (error "Invalid argument: %S" arg))))
+                               args)))
+    (dolist (arg args)
+      (cond
+       ((floatp arg) (osc-insert-float32 arg))
+       ((integerp arg) (osc-insert-int32 arg))
+       ((stringp arg) (osc-insert-string arg))))
+    (process-send-string client (buffer-string))))
+
+(defun osc-read-string ()
+  (let ((pos (point)) string)
+    (while (not (= (following-char) 0)) (forward-char 1))
+    (setq string (buffer-substring-no-properties pos (point)))
+    (forward-char (- 4 (% (length string) 4)))
+    string))
+
+(defun osc-read-int32 ()
+  (let ((value 0))
+    (dotimes (i 4)
+      (setq value (logior (* value 256) (following-char)))
+      (forward-char 1))
+    value))
+
+(defun osc-read-float32 ()
+  (let ((s (lsh (logand (following-char) #X80) -7))
+       (e (+ (lsh (logand (following-char) #X7F) 1)
+             (lsh (logand (progn (forward-char) (following-char)) #X80) -7)))
+       (f (+ (lsh (logand (following-char) #X7F) 16)
+             (lsh (progn (forward-char) (following-char)) 8)
+             (prog1 (progn (forward-char) (following-char)) (forward-char)))))
+    (cond
+     ((and (= e 0) (= f 0))
+      (* 0.0 (expt -1 s)))
+     ((and (= e 255) (or (= f (1- (expt 2 23))) (= f 0)))
+      (* 1.0e+INF (expt -1 s)))
+     ((and (= e 255) (not (or (= f 0) (= f (1- (expt 2 23))))))
+      0.0e+NaN)
+     (t
+      (* (expt -1 s)
+        (expt 2.0 (- e 127))
+        (1+ (/ f (expt 2.0 23))))))))
+
+(defun osc-server-set-handler (server path handler)
+  "Set HANDLER for PATH on SERVER.
+IF HANDLER is nil, remove previously defined handler and fallback to
+the generic handler for SERVER."
+  (let* ((handlers (plist-get (process-plist server) :handlers))
+        (slot (assoc-string path handlers)))
+    (if slot
+       (setcdr slot handler)
+      (plist-put
+       (process-plist server)
+       :handlers (nconc (list (cons path handler)) handlers)))))
+
+(defun osc-server-get-handler (server path)
+  (or (cdr (assoc path (plist-get (process-plist server) :handlers)))
+      (plist-get (process-plist server) :generic)))
+
+(defun osc-filter (proc string)
+  (when (= (% (length string) 4) 0)
+    (with-temp-buffer
+      (set-buffer-multibyte nil)
+      (insert string)
+      (goto-char (point-min))
+      (let ((path (osc-read-string)))
+       (if (not (string= path "#bundle"))
+           (when (looking-at ",")
+             (save-excursion
+               (apply (osc-server-get-handler proc path)
+                      path
+                      (mapcar
+                       (lambda (type)
+                         (case type
+                           (?f (osc-read-float32))
+                           (?i (osc-read-int32))
+                           (?s (osc-read-string))))
+                       (string-to-list (substring (osc-read-string) 1))))))
+         (forward-char 8) ;skip 64-bit timetag
+         (while (not (eobp))
+           (let ((size (osc-read-int32)))
+             (osc-filter proc
+                         (buffer-substring
+                          (point) (progn (forward-char size) (point)))))))))))
+
+;;;###autoload
+(defun osc-make-server (host port default-handler)
+  "Create an OSC server which listens on HOST and PORT.
+DEFAULT-HANDLER is a function with arguments (path &rest args) which is called
+when a new OSC message arrives.  See `osc-server-set-handler' for more
+fine grained control.
+A process object is returned which can be dicarded with `delete-process'."
+  (make-network-process
+   :name "OSCserver"
+   :filter #'osc-filter
+   :host host
+   :service port
+   :server t
+   :type 'datagram
+   :plist (list :generic default-handler)))
+
+(defun osc--test-transport-equality (value)
+  "Test if transporting a certain VALUE via OSC results in equality.
+This is mostly for testing the implementation robustness."
+  (let* ((osc-test-value value)
+        (osc-test-func (cond ((or (floatp value) (integerp value)) '=)
+                             ((stringp value) 'string=)))
+        (osc-test-done nil)
+        (osc-test-ok nil)
+        (server (osc-make-server
+                 "localhost" t
+                 (lambda (path v)
+                   (setq osc-test-done t
+                         osc-test-ok (list v (funcall osc-test-func
+                                                      osc-test-value v))))))
+        (client (osc-make-client
+                 (nth 0 (process-contact server)) (nth 1 (process-contact 
server)))))
+    (osc-send-message client
+                     "/test" osc-test-value)
+    (while (not osc-test-done)
+      (accept-process-output server 0 500))
+    (delete-process server) (delete-process client)
+    osc-test-ok))
+
+(provide 'osc)
+;;; osc.el ends here