Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
154 lines (134 sloc) 4.96 KB
;;; -*- 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)
(:reader (in)
(loop with value = 0
for lsb to (* 8 (1- bytes)) by 8 do
(setf (ldb (byte 8 lsb) value) (read-byte in))
finally (return value)))
(:writer (out value)
(loop for lsb to (* 8 (1- bytes)) by 8
do (write-byte (ldb (byte 8 lsb) value) out))))
(define-binary-type u1 () (integer :bytes 1))
(define-binary-type u2 () (integer :bytes 2))
(define-binary-type u3 () (integer :bytes 3))
(define-binary-type u4 () (integer :bytes 4))
(define-binary-type 1-bit ()
(:reader (in)
(read-bit in))
(:writer (out value)))
(define-binary-type n-bits (n)
(:reader (in)
(read-n-bits n in))
(:writer (out value)))
;;;
(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)
(write-sequence value out)))
(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))))
(defclass ogg-stream (fundamental-binary-input-stream)
((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)
(bits-left :initarg :bits-left
:initform 8
:accessor bits-left)))
(defmacro with-ogg-stream ((stream file &key) &body body)
(let ((file-stream (gensym)))
`(with-open-file (,file-stream ,file :element-type '(unsigned-byte 8))
(let ((,stream (make-instance 'ogg-stream :stream ,file-stream)))
,@body))))
(defun refill-stream (ogg-stream)
(with-slots (stream page position length) ogg-stream
(binary-data::read-object page stream)
(setf position 0
length (data-size page)
(bits-left ogg-stream) 8))
ogg-stream)
(defmethod stream-read-byte ((stream ogg-stream))
(let ((position (ogg-page-position stream)))
(when (= position (ogg-page-length stream))
(setf position 0)
(refill-stream stream))
(let ((data (data (ogg-page stream)))
(bits-left (bits-left stream)))
(cond ((= bits-left 8)
(prog1
(aref data position)
(incf (ogg-page-position stream))))
(t
(read-n-bits 8 stream))))))
(defmethod stream-read-sequence ((stream ogg-stream) sequence start end &key)
(loop for i from start below (or end (length sequence))
do (setf (aref sequence i)
(read-byte stream))
finally (return i)))
(defun read-bit (stream)
(plusp (read-n-bits 1 stream)))
(defun read-n-bits (n stream)
(cond ((> n 8)
(multiple-value-bind (quot rem) (floor n 8)
(logior (read-n-bits rem stream))))
(t
(let ((position (ogg-page-position stream)))
(when (= position (ogg-page-length stream))
(setf position 0)
(refill-stream stream))
(let ((data (data (ogg-page stream)))
(bits-left (bits-left stream)))
(prog1
(if (> n bits-left)
(logior (ldb (byte (min n bits-left) (- 8 bits-left))
(aref data position))
(ash (ldb (byte (- n bits-left) 0)
(aref data (1+ position)))
bits-left))
(ldb (byte (min n bits-left) (- 8 bits-left))
(aref data position)))
(cond ((> n bits-left)
(incf (ogg-page-position stream))
(setf (bits-left stream)
(- 8 (- n bits-left))))
(t
(decf (bits-left stream) n)))))))))