Initial commit.

binary-data.lisp

@@ -0,0 +1,205 @@
+;; Copyright (c) 2005, Peter Seibel All rights reserved.
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are
+;; met:
+
+;;     * Redistributions of source code must retain the above copyright
+;;       notice, this list of conditions and the following disclaimer.
+
+;;     * Redistributions in binary form must reproduce the above
+;;       copyright notice, this list of conditions and the following
+;;       disclaimer in the documentation and/or other materials provided
+;;       with the distribution.
+
+;;     * Neither the name of the Peter Seibel nor the names of its
+;;       contributors may be used to endorse or promote products derived
+;;       from this software without specific prior written permission.
+
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(in-package :binary-data)
+
+(defmacro with-gensyms ((&rest names) &body body)
+  `(let ,(loop for n in names collect `(,n (make-symbol ,(string n))))
+     ,@body))
+
+;;;
+
+(defvar *in-progress-objects* nil)
+
+(defconstant +null+ (code-char 0))
+
+(defgeneric read-value (type stream &key)
+  (:documentation "Read a value of the given type from the stream."))
+
+(defgeneric write-value (type stream value &key)
+  (:documentation "Write a value as the given type to the stream."))
+
+(defgeneric read-object (object stream)
+  (:method-combination progn :most-specific-last)
+  (:documentation "Fill in the slots of object from stream."))
+
+(defgeneric write-object (object stream)
+  (:method-combination progn :most-specific-last)
+  (:documentation "Write out the slots of object to the stream."))
+
+(defmethod read-value ((type symbol) stream &key)
+  (let ((object (make-instance type)))
+    (read-object object stream)
+    object))
+
+(defmethod write-value ((type symbol) stream value &key)
+  (assert (typep value type))
+  (write-object value stream))
+
+
+;;; Binary types
+
+(defun normilize-keyword-args (args)
+  (mapcar (lambda (arg)
+            (etypecase arg
+              (symbol arg)
+              ((cons symbol *)
+               (car arg))
+              ((cons (cons symbol (cons symbol null)) *)
+               (cadar arg))))
+          args))
+
+(defmacro define-binary-type (name (&rest args) &body spec)
+  (with-gensyms (type stream value)
+  `(progn
+    (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args)
+      (declare (ignorable ,@(normilize-keyword-args args)))
+      ,(type-reader-body spec stream))
+    (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args)
+      (declare (ignorable ,@(normilize-keyword-args args)))
+      ,(type-writer-body spec stream value)))))
+
+(defun type-reader-body (spec stream)
+  (ecase (length spec)
+    (1 (destructuring-bind (type &rest args) (mklist (first spec))
+         `(read-value ',type ,stream ,@args)))
+    (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec))
+         `(let ((,in ,stream)) ,@body)))))
+
+(defun type-writer-body (spec stream value)
+  (ecase (length spec)
+    (1 (destructuring-bind (type &rest args) (mklist (first spec))
+         `(write-value ',type ,stream ,value ,@args)))
+    (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec))
+         `(let ((,out ,stream) (,v ,value)) ,@body)))))
+
+
+;;; Binary classes
+
+(defmacro define-generic-binary-class (name (&rest superclasses) slots read-method)
+  (with-gensyms (objectvar streamvar)
+    `(progn
+       (eval-when (:compile-toplevel :load-toplevel :execute)
+         (setf (get ',name 'slots) ',(mapcar #'first slots))
+         (setf (get ',name 'superclasses) ',superclasses))
+
+       (defclass ,name ,superclasses
+         ,(mapcar #'slot->defclass-slot slots))
+
+       ,read-method
+
+       (defmethod write-object progn ((,objectvar ,name) ,streamvar)
+         (declare (ignorable ,streamvar))
+         (with-slots ,(new-class-all-slots slots superclasses) ,objectvar
+           ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots))))))
+
+(defmacro define-binary-class (name (&rest superclasses) slots)
+  (with-gensyms (objectvar streamvar)
+    `(define-generic-binary-class ,name ,superclasses ,slots
+       (defmethod read-object progn ((,objectvar ,name) ,streamvar)
+         (declare (ignorable ,streamvar))
+         (with-slots ,(new-class-all-slots slots superclasses) ,objectvar
+           ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots))))))
+
+(defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options)
+  (with-gensyms (typevar objectvar streamvar)
+    `(define-generic-binary-class ,name ,superclasses ,slots
+      (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key)
+        (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots)
+          (let ((,objectvar
+                 (make-instance
+                  ,@(or (cdr (assoc :dispatch options))
+                        (error "Must supply :disptach form."))
+                  ,@(mapcan #'slot->keyword-arg slots))))
+            (read-object ,objectvar ,streamvar)
+            ,objectvar))))))
+
+(defun as-keyword (sym) (intern (string sym) :keyword))
+
+(defun normalize-slot-spec (spec)
+  (list (first spec) (mklist (second spec))))
+
+(defun mklist (x) (if (listp x) x (list x)))
+
+(defun slot->defclass-slot (spec)
+  (let ((name (first spec)))
+    `(,name :initarg ,(as-keyword name) :accessor ,name)))
+
+(defun slot->read-value (spec stream)
+  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
+    `(setf ,name (read-value ',type ,stream ,@args))))
+
+(defun slot->write-value (spec stream)
+  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
+    `(write-value ',type ,stream ,name ,@args)))
+
+(defun slot->binding (spec stream)
+  (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec)
+    `(,name (read-value ',type ,stream ,@args))))
+
+(defun slot->keyword-arg (spec)
+  (let ((name (first spec)))
+    `(,(as-keyword name) ,name)))
+
+;;; Keeping track of inherited slots
+
+(defun direct-slots (name)
+  (copy-list (get name 'slots)))
+
+(defun inherited-slots (name)
+  (loop for super in (get name 'superclasses)
+        nconc (direct-slots super)
+        nconc (inherited-slots super)))
+
+(defun all-slots (name)
+  (nconc (direct-slots name) (inherited-slots name)))
+
+(defun new-class-all-slots (slots superclasses)
+  "Like all slots but works while compiling a new class before slots
+and superclasses have been saved."
+  (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots)))
+
+;;; In progress Object stack
+
+(defun current-binary-object ()
+  (first *in-progress-objects*))
+
+(defun parent-of-type (type)
+  (find-if #'(lambda (x) (typep x type)) *in-progress-objects*))
+
+(defmethod read-object :around (object stream)
+  (declare (ignore stream))
+  (let ((*in-progress-objects* (cons object *in-progress-objects*)))
+    (call-next-method)))
+
+(defmethod write-object :around (object stream)
+  (declare (ignore stream))
+  (let ((*in-progress-objects* (cons object *in-progress-objects*)))
+    (call-next-method)))

ogg-page.lisp

@@ -0,0 +1,107 @@
+;;; -*- Mode: Lisp -*-
+
+;;; This software is in the public domain and is
+;;; provided with absolutely no warranty.
+
+(in-package #:ogg)
+
+(define-binary-type ascii-string (length)
+  (:reader (in)
+           (let ((string (make-string length)))
+             (loop for i below length
+                   do (setf (char string i)
+                            (code-char (read-byte in))))
+             string))
+  (:writer (out value)))
+
+(define-binary-type integer (bytes (bits-per-byte 8))
+  (:reader (in)
+    (loop with value = 0
+          for lsb to (* bits-per-byte (1- bytes)) by bits-per-byte do
+          (setf (ldb (byte bits-per-byte lsb) value) (read-byte in))
+       finally (return value)))
+  (:writer (out value)
+           (loop for lsb to (* bits-per-byte (1- bytes)) by bits-per-byte
+                 do (write-byte (ldb (byte bits-per-byte lsb) value) out))))
+
+(define-binary-type u1 () (integer :bytes 1))
+(define-binary-type u4 () (integer :bytes 4))
+
+;;;
+
+(define-binary-type vector (length)
+  (:reader (in)
+           (let ((vector (make-array length :element-type '(unsigned-byte 8))))
+             (read-sequence vector in)
+             vector))
+  (:writer (out value)))
+
+(define-binary-type header-type-flag ()
+  (:reader (in)
+           (let ((byte (read-byte in)))
+             (values (logbitp 0 byte)
+                     (logbitp 1 byte)
+                     (logbitp 3 byte))))
+  (:writer (out value)))
+
+(define-binary-type data-size (length)
+  (:reader (in)
+           (loop repeat length
+                 sum (read-byte in)))
+  (:writer (out value)))
+
+(define-binary-class ogg-page ()
+  ((magick   (ascii-string :length 4))
+   (version  u1)
+   (type-flag  header-type-flag)
+   (granule-position (vector :length 8))
+   (bitstream-serial-number u4)
+   (page-sequence-number u4)
+   (crc u4)
+   (number-page-segments u1)
+   (data-size (data-size :length number-page-segments))
+   (data (vector :length data-size))))
+
+(defun parse-page (stream)
+  (read-value 'ogg-page stream))
+
+(defun read-file (file)
+  (with-open-file (stream file :element-type 'unsigned-byte)
+    (parse-page stream)))
+
+(defmacro with-ogg-stream ((stream file) &body body)
+  (let ((file-stream (gensym)))
+    `(with-open-file (,file-stream ,file :element-type 'unsigned-byte)
+       (let ((,stream (make-instance 'ogg-stream :stream ,file-stream)))
+         ,@body))))
+
+(defclass ogg-stream (fundamental-binary-stream
+                      trivial-gray-stream-mixin)
+  ((stream :initarg :stream
+           :reader ogg-stream)
+   (page :initform (make-instance 'ogg-page)
+         :reader ogg-page)
+   (position :initform 0 :accessor ogg-page-position)
+   (length :initform 0 :accessor ogg-page-length)))
+
+(defun refill-stream (ogg-stream)
+  (with-slots (stream page position length) ogg-stream
+    (read-object page stream)
+    (setf position 0
+          length (data-size page)))
+  ogg-stream)
+
+(defmethod stream-read-byte ((stream ogg-stream))
+  (when (= (ogg-page-position stream)
+           (ogg-page-length stream))
+    (refill-stream stream))
+  (prog1 (aref (data (ogg-page stream))
+               (ogg-page-position stream))
+    (incf (ogg-page-position stream))))
+
+(defmethod stream-read-sequence ((stream ogg-stream) sequence start end &key)
+  (loop for i from (or start 0) below (max (length sequence)
+                                           (or end 0))
+        do (setf (aref sequence i)
+                 (read-byte stream))
+        finally (return i)))

ogg-vorbis.lisp

@@ -0,0 +1,54 @@
+;;; -*- Mode: Lisp -*-
+
+;;; This software is in the public domain and is
+;;; provided with absolutely no warranty.
+
+(in-package #:ogg)
+
+(define-binary-type utf8-string (length)
+  (:reader (in)
+           (babel:octets-to-string
+            (read-value 'vector in :length length)
+            :encoding :utf-8))
+  (:writer (out value)))
+
+(define-tagged-binary-class vorbis ()
+  ((packet-type u1)
+   (magick   (ascii-string :length 6)))
+  (:dispatch
+   (ecase packet-type
+     (1 'vorbis-id-header)
+     (3 'vorbis-comment-header))))
+
+(define-binary-class vorbis-id-header (vorbis)
+  ((version u4)
+   (audio-channels u1)
+   (audio-sample-rate u4)
+   (bitrate-maximum u4)
+   (bitrate-nominal u4)
+   (bitrate-minimum u4)
+   (block-size u1)
+   (framing-flag u1)))
+
+(define-binary-class comment ()
+  ((comment-length u4)
+   (comment (utf8-string :length comment-length))))
+
+(define-binary-type comments (length)
+  (:reader (in)
+           (loop repeat length
+                 nconc (parse-comment-string
+                        (comment (read-value 'comment in)))))
+  (:writer (out value)))
+
+(define-binary-class vorbis-comment-header (vorbis)
+  ((vendor-length u4)
+   (vendor-string (utf8-string :length vendor-length))
+   (comments-length u4)
+   (comments (comments :length comments-length))))
+
+(defun parse-comment-string (string)
+  (let ((=-position (position #\= string)))
+    (assert (numberp =-position))
+    (list (intern (nstring-upcase (subseq string 0 =-position)) :keyword)
+          (subseq string (1+ =-position)))))

ogg.asd

@@ -0,0 +1,9 @@
+;;; -*- Mode: Lisp -*-
+
+(asdf:defsystem #:ogg
+  :serial t
+  :depends-on (trivial-gray-streams)
+  :components ((:file "packages")
+               (:file "binary-data")
+               (:file "ogg-page")
+               (:file "ogg-vorbis")))

packages.lisp

@@ -0,0 +1,19 @@
+;;; -*- Mode: Lisp -*-
+
+(defpackage #:binary-data
+  (:use #:cl)
+  (:export #:define-binary-class
+           #:define-tagged-binary-class
+           #:define-binary-type
+           #:read-value
+           #:write-value
+           #:read-object
+           #:*in-progress-objects*
+           #:parent-of-type
+           #:current-binary-object
+           #:+null+))
+
+(defpackage #:ogg
+  (:use #:cl #:binary-data
+        #:trivial-gray-streams)
+  (:export ))