Initial check in

.gitignore

@@ -0,0 +1,10 @@
+.*
+#*#
+*~
+!.gitignore
+*.so
+*.fas
+*.lx64fsl
+*.lib
+*.bak
+*.orig

LICENSE

@@ -0,0 +1,37 @@
+taglib software and associated documentation are in the public
+domain:
+
+  Authors dedicate this work to public domain, for the benefit of the
+  public at large and to the detriment of the authors' heirs and
+  successors. Authors intends this dedication to be an overt act of
+  relinquishment in perpetuity of all present and future rights under
+  copyright law, whether vested or contingent, in the work. Authors
+  understands that such relinquishment of all rights includes the
+  relinquishment of all rights to enforce (by lawsuit or otherwise)
+  those copyrights in the work.
+
+  Authors recognize that, once placed in the public domain, the work
+  may be freely reproduced, distributed, transmitted, used, modified,
+  built upon, or otherwise exploited by anyone for any purpose,
+  commercial or non-commercial, and in any way, including by methods
+  that have not yet been invented or conceived.
+
+In those legislations where public domain dedications are not
+recognized or possible, taglib is distributed under the following
+terms and conditions:
+
+  Permission is hereby granted, free of charge, to any person
+  obtaining a copy of this software and associated documentation files
+  (the "Software"), to deal in the Software without restriction,
+  including without limitation the rights to use, copy, modify, merge,
+  publish, distribute, sublicense, and/or sell copies of the Software,
+  and to permit persons to whom the Software is furnished to do so,
+  subject to the following conditions:
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

README.md

@@ -0,0 +1,8 @@
+Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+
+A pure Lisp implementation for reading MPEG-4 audio and MPEG-3 audio tags.
+
+Make your life simple---install quicklisp to get all the dependencies loaded!
+
+
+

base-file.lisp

@@ -0,0 +1,96 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: BASE-FILE; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+
+(in-package #:base-file)
+
+(log5:defcategory cat-log-base-file)
+(defmacro log-base-file (&rest log-stuff) `(log5:log-for (cat-log-base-file) ,@log-stuff))
+
+(deftype octet () '(unsigned-byte 8))
+(defmacro make-octets (len) `(make-array ,len :element-type 'octet))
+
+(defclass base-file ()
+  ((filename  :accessor filename  :initarg :filename)
+   (instream  :accessor instream  :initform nil)
+   (endian    :accessor endian    :initarg :endian :initform nil)   ; controls endian-ness of read/writes
+   (modified  :accessor modified  :initform nil)					; for when we implement writing tags
+   (file-size :accessor file-size))
+  (:documentation "Base class for all audio file types"))
+
+(defmethod initialize-instance :after ((me base-file) &key read-only &allow-other-keys)
+  (log5:with-context "base-file-initializer"
+  (with-slots (instream filename file-size endian) me
+	(setf instream (if read-only
+					   (open filename :direction :input :element-type 'octet)
+					   (open filename :direction :io :if-exists :overwrite :element-type 'octet)))
+	(setf binary-types:*endian* endian)
+	(setf file-size (file-length instream))
+	(log-base-file "stream = ~a, name = ~a, size = ~:d~%endian = ~a"
+				   instream filename file-size endian))))
+
+(defmethod close-audio-file ((me base-file))
+  "Close an open file"
+  (with-slots (instream modified) me
+	(when modified
+	  (warn "at some point, should I add code to auto-write modified audio-files?")
+	  (setf modified nil))
+	(when instream
+	  (close instream)
+	  (setf instream nil))))
+
+(defmethod seek ((me base-file) offset from)
+  "C-library like seek function. from can be one of :current, :start, :end.
+Returns the current offset into the stream"
+  (assert (member from '(:current :start :end)) () "seek takes one of :current, :start, :end")
+  (with-slots (instream file-size) me
+	(ecase from
+	  (:start (file-position instream offset))
+	  (:current
+	   (let ((current (file-position instream)))
+		 (file-position instream (+ current offset))))
+	  (:end
+	   (file-position instream (- file-size offset))))))
+
+(defmethod read-u8 ((me base-file))
+  "read 1 byte from file"
+  (multiple-value-bind (value size) (binary-types:read-binary 'u8 (slot-value me 'instream))
+	(assert (= size 1) () "Expected to read 1 byte, got ~d instead" size)
+	value))
+
+(defmethod read-u16 ((me base-file))
+  "read 2 bytes from file"
+  (multiple-value-bind (value size) (binary-types:read-binary 'u16 (slot-value me 'instream))
+	(assert (= size 2) () "Expected to read 2 bytes, got ~d instead" size)
+	value))
+
+;;; read 3-bytes
+(binary-types:define-unsigned u24 3)
+
+(defmethod read-u24 ((me base-file))
+  "read 3 bytes from file"
+  (multiple-value-bind (value size) (binary-types:read-binary 'u24 (slot-value me 'instream))
+	(assert (= size 3) () "Expected to read 3 bytes, got ~d instead" size)
+	value))
+
+(defmethod read-u32 ((me base-file))
+  "read 4 bytes from file"
+  (multiple-value-bind (value size) (binary-types:read-binary 'u32 (slot-value me 'instream))
+	(assert (= size 4) () "Expected to read 4 bytes, got ~d instead" size)
+	value))
+
+(defmethod read-string ((me base-file) &key size (terminators nil))
+  "Read normal string from file. If size is provided, read exactly that many octets.
+If terminators is supplied, it is a list of characters that can terminate a string (and hence stop read)"
+  (multiple-value-bind (value read-size)
+	  (binary-types:read-binary-string (slot-value me 'instream) :size size :terminators terminators)
+	(declare (ignore read-size))
+	;; what checks should happen here?
+	value))
+
+(defmethod read-octets ((me base-file) size)
+  "Read SIZE octets from input-file"
+  (let* ((octets (make-octets size))
+		 (read-len (read-sequence octets (slot-value me 'instream))))
+	(assert (= read-len size))
+	octets))
+

logging.lisp

@@ -0,0 +1,36 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: LOGGING; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+
+(in-package #:logging)
+
+(defmacro start-logging ((name spec) &body body)
+  `(unwind-protect 
+		(progn
+		  (log5:start-sender 'trace-log
+			  (log5:stream-sender :location ,name)
+			  :category-spec ,spec
+			  :output-spec '(log5:message log5:context))
+		  ,@body)
+	 (log5:stop-sender 'trace-log)))
+
+
+(defparameter *logging-categories* '(mp4-atom::cat-log-mp4-atom
+									 mp4-file::cat-log-mp4-file
+									 base-file::cat-log-base-file
+									 mp3-frame::cat-log-mp3-frame
+									 mp3-file::cat-log-mp3-file))
+
+(defmacro with-logging ((&key (file nil) (categories *logging-categories*)) &body body)
+  (alexandria:with-gensyms (output-stream)
+	`(let (,output-stream)
+	   (unwind-protect
+			(setf ,output-stream (if ,file
+									 (open ,file :direction :output :if-exists :overwrite :if-does-not-exist :create)
+									 *standard-output*))
+			(log5:start-sender 'trace-log (log5:stream-sender :location ,output-stream)
+							   :category-spec ',categories
+							   :output-spec '(log5:message log5:context))
+			,@body)
+	   (if ,file (close ,output-stream))
+	   (log5:stop-sender 'trace-log))))
+

mp3-file.lisp

@@ -0,0 +1,40 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: MP3-FILE; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+
+(in-package :mp3-file)
+
+(log5:defcategory cat-log-mp3-file)
+
+(defmacro log-mp3-file (&rest log-stuff) `(log5:log-for (cat-log-mp3-file) ,@log-stuff))
+
+(defclass mp3-file (base-file:base-file)
+  ((header :accessor header :initform nil))
+  (:documentation "Class to access mp3 files"))
+
+(defun make-mp3-file (filename read-only &key)
+  "Convenience function to create an instance of MP3-FILE with appropriate init args.
+NB: we assume non-syncsafe as default"
+  (log5:with-context "make-mp3-file"
+	(log-mp3-file "opening ~a" filename)
+	(let (handle)
+	  (handler-case 
+		  (progn
+			(setf handle (make-instance 'mp3-file :filename filename :endian :little-endian :read-only read-only))
+			(with-slots (header) handle
+			  (log-mp3-file "getting frames")
+			  (setf header (mp3-frame:find-mp3-frames handle))))
+		(condition (c)
+		  (warn "make-mp3-file got condition: ~a" c)
+		  (when handle (base-file:close-audio-file handle))
+		  (setf handle nil)))
+	  handle)))
+
+(defmethod read-sync-safe-u32 ((me mp3-file))
+  "Read a sync-safe integer from file.  Used by mp3 files"
+  (let* ((ret 0))
+	(setf (ldb (byte 7 21) ret) (base-file:read-u8 me))
+	(setf (ldb (byte 7 14) ret) (base-file:read-u8 me))
+	(setf (ldb (byte 7 7) ret)  (base-file:read-u8 me))
+	(setf (ldb (byte 7 0) ret)  (base-file:read-u8 me))
+	ret))
+

mp3-frame.lisp

@@ -0,0 +1,295 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: MP-FRAME; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+
+(in-package #:mp3-frame)
+
+(log5:defcategory cat-log-mp3-frame)
+(defmacro log-mp3-frame (&rest log-stuff) `(log5:log-for (cat-log-mp3-frame) ,@log-stuff))
+
+(define-condition mp3-frame-condition ()
+  ((location :initarg :location :reader location :initform nil)
+   (object   :initarg :object   :reader object   :initform nil)
+   (messsage :initarg :message  :reader message  :initform "Undefined Condition"))
+  (:report (lambda (condition stream)
+			 (format stream "mp3-frame condition at location: <~a> with object: <~a>: message: <~a>"
+					 (location condition) (object condition) (message condition)))))
+
+(defmethod print-object ((me mp3-frame-condition) stream)
+  (format stream "location: <~a>, object: <~a>, message: <~a>" (location me) (object me) (message me)))
+
+(defparameter *pprint-mp3-frame* nil
+  "Controls whether we pretty print frame data")
+
+(defclass mp3-id3-header ()
+  ((version        :accessor version        :initarg :version        :initform 0)
+   (revision       :accessor revision       :initarg :revision       :initform 0)
+   (flags          :accessor flags          :initarg :flags          :initform 0)
+   (size           :accessor size           :initarg :size           :initform 0)
+   (ext-header     :accessor ext-header     :initarg :ext-header     :initform nil)
+   (frames	       :accessor frames	        :initarg :frames		 :initform nil)
+   (v21-tag-header :accessor v21-tag-header :initarg :v21-tag-header :initform nil))
+  (:documentation "The ID3 header, found at start of file"))
+
+(defmethod vpprint ((me mp3-id3-header) stream &key (indent 0))
+  "Set *pprint-mp3-frame* to get pretty printing and call print-object via format"
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+(defun is-valid-mp3-file (mp3-file)
+  "Make sure this is an MP3 file. Look for frames at begining and/or end"
+  (log5:with-context "is-valid-mp3-file"
+	(seek mp3-file 0 :start)
+	(let* ((id3 (read-string mp3-file :size 3))
+		   (version (read-u8 mp3-file))
+		   (tag))
+	  (seek mp3-file 128 :end)
+	  (setf tag (read-string mp3-file :size 3))
+	  (seek mp3-file 0 :start)
+
+	  (log-mp3-frame "id3 = ~a, version = ~d" id3 version)
+
+	  (or (and (string= "ID3" id3)
+			   (or (= 2 version) (= 3 version) (= 4 version)))
+		  (string= tag "TAG")))))
+
+(defclass v21-tag-header ()
+  ((songname :accessor songname :initarg :songname :initform nil)
+   (artist   :accessor artist   :initarg :artist   :initform nil)
+   (album    :accessor album    :initarg :album    :initform nil)
+   (year     :accessor year     :initarg :year     :initform nil)
+   (comment  :accessor comment  :initarg :comment  :initform nil)
+   (genre    :accessor genre    :initarg :genre    :initform nil))
+  (:documentation "ID3 V2.1 old-style tag.  If present, found in last 128 bytes of file."))
+
+(defmethod vpprint ((me v21-tag-header) stream &key (indent 0))
+  "Set *pprint-mp3-frame* to get pretty printing and call print-object via format"
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+(defmethod print-object ((me v21-tag-header) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (songname artist album year comment genre) me
+		(format stream "songname = <~a>, artist = <~a>, album = <~a>, year = <~a>, comment = <~a>, genre = ~d"
+				songname artist album year comment genre))))
+
+(defmethod initialize-instance ((me v21-tag-header) &key instream)
+  "Read in a V2.1 tag.  Caller will have seek'ed file to correct location and ensured that TAG was present"
+  (log5:with-context "v21-frame-initializer"
+	(log-mp3-frame "reading v2.1 tag")
+	(with-slots (songname artist album year comment genre) me
+	  (setf songname (read-string instream :size 30 :terminators '(0)))
+	  (setf artist   (read-string instream :size 30 :terminators '(0)))
+	  (setf album    (read-string instream :size 30 :terminators '(0)))
+	  (setf year     (read-string instream :size 4  :terminators '(0)))
+	  (setf comment  (read-string instream :size 30 :terminators '(0)))
+	  (setf genre    (read-u8 instream))
+	  (log-mp3-frame "v21 tag: ~a" (vpprint me nil)))))
+
+(defclass mp3-ext-header ()
+  ((size    :accessor size    :initarg :size    :initform 0)
+   (flags   :accessor flags   :initarg :flags   :initform 0)
+   (padding :accessor padding :initarg :padding :initform 0)
+   (crc	    :accessor crc     :initarg :crc     :initform nil))
+  (:documentation "class representing a V2.3/4 extended header"))
+
+(defmethod vpprint ((me mp3-ext-header) stream &key (indent 0))
+  "Set *pprint-mp3-frame* to get pretty printing and call print-object via format"
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+(defmacro ext-header-crc-p (flags)	 `(logbitp 15 ,flags))
+
+(defmethod initialize-instance ((me mp3-ext-header) &key instream)
+  "Read in the extended header.  Caller will have seek'ed to correct location in file."
+  (with-slots (size flags padding crc) me
+	(setf size (read-u32 instream))
+	(setf flags (read-u16 instream))
+	(setf padding (read-u32 instream))
+	(when (ext-header-crc-p flags)
+	  (setf crc (read-u32 instream)))))
+
+(defmethod print-object ((me mp3-ext-header) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (size flags padding crc) me
+		(format stream "extended header: size: ~d, flags: ~x, padding ~:d, crc = ~x~%"
+				size flags padding crc))))
+
+(defmacro header-unsynchronized-p (flags) `(logbitp 7 ,flags))
+(defmacro header-extended-p (flags)       `(logbitp 6 ,flags))
+(defmacro header-experimental-p (flags)   `(logbitp 5 ,flags)) 
+(defmacro header-footer-p (flags)		  `(logbitp 4 ,flags)) ;; N.B. *NOT* defined for 2.3 tags
+
+(defmacro print-header-flags (stream flags)
+  `(format ,stream "0x~2,'0x: ~:[0/~;unsynchronized-frames/~]~:[0/~;extended-header/~]~:[0/~;expermental-tag/~]~:[0~;footer-present~]"
+		   ,flags
+		   (header-unsynchronized-p ,flags)
+		   (header-extended-p ,flags)
+		   (header-experimental-p ,flags)
+		   (header-footer-p ,flags)))
+
+(defmethod print-object ((me mp3-id3-header) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (version revision flags v21-tag-header size ext-header frames) me
+		(format stream "Header: version/revision: ~d/~d, flags: ~a, size = ~:d bytes; ~a; ~a"
+				version revision (print-header-flags nil flags) size
+				(if (header-extended-p flags)
+					(concatenate 'string "Extended header: " (vpprint ext-header nil))
+					"No extended header")
+				(if v21-tag-header
+					(concatenate 'string "V21 tag: " (vpprint v21-tag-header nil))
+					"No v21 tag"))
+		(when frames
+		  (format stream "~4tFrames[~d]:~%~{~8t~a~^~%~}" (length frames) frames)))))
+
+(defmethod initialize-instance :after ((me mp3-id3-header) &key instream &allow-other-keys)
+  "Fill in an mp3-header from file."
+  (log5:with-context "mp3-id3-header-initializer"
+	(with-slots (version revision flags size ext-header frames v21-tag-header) me
+	  (seek instream 128 :end)
+	  (when (string= "TAG" (read-string instream :size 3))
+		(log-mp3-frame "looking at last 128 bytes at ~:d to try to read id3v21 header" (seek instream 0 :current))
+		(handler-case
+			(setf v21-tag-header (make-instance 'v21-tag-header :instream instream))
+		  (condition (c)
+			(log-mp3-frame "reading v21 got condition: ~a" c))))
+
+	  (seek instream 0 :start)
+	  (when (string= "ID3" (read-string instream :size 3))
+		(setf version (read-u8 instream))
+		(setf revision (read-u8 instream))
+		(setf flags (read-u8 instream))
+		(setf size (mp3-file:read-sync-safe-u32 instream))
+		(when (header-unsynchronized-p flags) (log-mp3-frame "unsync"))
+		(assert (not (header-footer-p flags)) () "Can't decode ID3 footer's yet")
+		(when (header-extended-p flags)
+		  (setf ext-header (make-instance 'mp3-extended-header :instream instream))))
+
+	  (log-mp3-frame "~a" (vpprint me nil)))))
+
+(defclass id3-frame ()
+  ((pos     :accessor pos     :initarg :pos)
+   (version :accessor version :initarg :version)
+   (id      :accessor id      :initarg :id)
+   (len     :accessor len     :initarg :len)
+   (flags   :accessor flags   :initarg :flags :initform nil))
+  (:documentation   "Base class for an ID3 frame"))
+
+(defmacro frame-23-altertag-p  (frame-flags) `(logbitp 15 ,frame-flags))
+(defmacro frame-23-alterfile-p (frame-flags) `(logbitp 14 ,frame-flags))
+(defmacro frame-23-readonly-p  (frame-flags) `(logbitp 13 ,frame-flags))
+(defmacro frame-23-compress-p  (frame-flags) `(logbitp 7 ,frame-flags))
+(defmacro frame-23-encrypt-p   (frame-flags) `(logbitp 6 ,frame-flags))
+(defmacro frame-23-group-p     (frame-flags) `(logbitp 5 ,frame-flags))
+
+(defmacro frame-24-altertag-p  (frame-flags) `(logbitp 14 ,frame-flags))
+(defmacro frame-24-alterfile-p (frame-flags) `(logbitp 13 ,frame-flags))
+(defmacro frame-24-readonly-p  (frame-flags) `(logbitp 12 ,frame-flags))
+(defmacro frame-24-groupid-p   (frame-flags) `(logbitp 6 ,frame-flags))
+(defmacro frame-24-compress-p  (frame-flags) `(logbitp 3 ,frame-flags))
+(defmacro frame-24-encrypt-p   (frame-flags) `(logbitp 2 ,frame-flags))
+(defmacro frame-24-unsynch-p   (frame-flags) `(logbitp 1 ,frame-flags))
+(defmacro frame-24-datalen-p   (frame-flags) `(logbitp 0 ,frame-flags))
+
+(defun valid-frame-flags (header-version frame-flags)
+  (ecase header-version
+	(3 (zerop (logand #b0001111100011111 frame-flags)))
+	(4 (zerop (logand #b1000111110110000 frame-flags)))))
+
+(defmethod print-object ((me id3-frame) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (pos version valid-p id len flags) me
+		(format stream "@offset: ~:d, version = ~d, id: ~s, len: ~:d "
+				pos version id len)
+		(if flags
+			(ecase version
+			  (3 (format stream "flags: 0x~4,'0x: ~:[0/~;tag-alter-preservation/~]~:[0/~;file-alter-preservation/~]~:[0/~;read-only/~]~:[0/~;compress/~]~:[0/~;encypt/~]~:[0~;group~], "
+						 flags
+						 (frame-23-altertag-p flags)
+						 (frame-23-alterfile-p flags)
+						 (frame-23-readonly-p flags)
+						 (frame-23-compress-p flags)
+						 (frame-23-encrypt-p flags)
+						 (frame-23-group-p flags)))
+			  (4 (format stream "flags: 0x~4,'0x: ~:[0/~;tag-alter-preservation/~]~:[0/~;file-alter-preservation/~]~:[0/~;read-only/~]~:[0/~;group-id/~]~:[0/~;compress/~]~:[0/~;encypt/~]~:[0/~;unsynch/~]~:[0~;datalen~], "
+						 flags
+						 (frame-24-altertag-p flags)
+						 (frame-24-alterfile-p flags)
+						 (frame-24-readonly-p flags)
+						 (frame-24-groupid-p flags)
+						 (frame-24-compress-p flags)
+						 (frame-24-encrypt-p flags)
+						 (frame-24-unsynch-p flags)
+						 (frame-24-datalen-p flags))))))))
+
+(defclass raw-frame (id3-frame)
+  ((octets :accessor octets :initform nil))
+  (:documentation "Frame class that slurps in frame contents"))
+
+(defmethod initialize-instance :after ((me raw-frame) &key instream)
+  (log5:with-context "raw-frame"
+	(with-slots (len octets) me
+	  (log-mp3-frame "reading ~:d bytes from position ~:d" len (seek instream 0 :current))
+	  (setf octets (read-octets instream len)))))
+
+(defmethod print-object :after ((me raw-frame) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (octets) me
+		(let* ((len (length (slot-value me 'octets)))
+			   (print-len (min len 10))
+			   (printable-array (make-array print-len :displaced-to (slot-value me 'octets))))
+		  (format stream "[~:d of ~:d bytes] <~x>" print-len len printable-array)))))
+
+(defun find-id3-frames (header instream)
+  "Loop thru all the frames in INSTREAM based on information from HEADER"
+  (labels ((read-and-de-sync (instream len)
+			 "Used to undo sync-safe when the header says false syncs have been removed from the tags"
+			 (let* ((last-byte-was-FF nil)
+					(byte nil)
+					(synced-frame-data (with-binary-output-to-vector (out)
+										 (dotimes (i len)
+										   (setf byte (read-byte instream))
+										   (if last-byte-was-FF
+											   (if (not (zerop byte))
+												   (write-byte byte out))
+											   (write-byte byte out))
+										   (setf last-byte-was-FF (= byte #xFF))))))
+			   synced-frame-data)))
+
+	(log5:with-context "find-id3-frames"
+	  nil)))
+
+;; 	  (let ((mem-stream)
+;; 			(first-byte))
+;; 		(if (header-unsynchronized-p header)
+;; 			(setf mem-stream (read-and-desync instream (size header)))
+;; 	   (log-mp3-frame "Looking for frames: header = ~a, starting position = ~:d" (mp3-frame:vpprint header nil) (seek instream 0 :current))
+;; 	 (loop
+;; 	   (let ((first-byte (read-u8 instream)))
+;; 		 (when (
+;; ;	 (if (header-unsynchronized-p (flags header))
+;; 	 (do* ((pos (seek instream 0 :current))
+;; 		   (frame)
+;; 		   (end (+ pos (size header))))
+;; 		  ((>= pos end))
+
+;; 	nil))
+
+(defun find-mp3-frames (mp3-file)
+  "With an open mp3-file, make sure it is in fact an MP3 file, then read it's header and frames, returning both"
+  (log5:with-context "find-mp3-frames"
+	(when (not (is-valid-mp3-file mp3-file))
+	  (log-mp3-frame "~a is not an mp3 file" (filename mp3-file))
+	  (error 'mp3-frame-condition :location "find-mp3-frames" :object (filename mp3-file) :message "is not an mp3 file"))
+
+ 	(log-mp3-frame "~a is a valid mp3 file" (filename mp3-file))
+
+	(let* ((header (make-instance 'mp3-id3-header :instream mp3-file))
+		   (frames (find-id3-frames header mp3-file)))
+	  (log-mp3-frame "Header: ~a, frames = ~a" header frames)
+	  (setf (slot-value header 'frames) frames))))
+

mp3-tag.lisp

@@ -0,0 +1,6 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: MP3-TAG; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+(in-package #:mp3-tag)
+
+(defmethod show-tags ((me mp3-file:mp3-file))
+  (format t "~a:~a~%" (base-file:filename me) (mp3-frame:vpprint (mp3-file:header me) nil)))

mp4-atom.lisp

@@ -0,0 +1,436 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: MP4-ATOM; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+(in-package #:mp4-atom)
+
+(log5:defcategory cat-log-mp4-atom)
+(defmacro log-mp4-atom (&rest log-stuff) `(log5:log-for (cat-log-mp4-atom) ,@log-stuff))
+
+(define-condition mp4-atom-condition ()
+  ((location :initarg :location :reader location :initform nil)
+   (object   :initarg :object   :reader object   :initform nil)
+   (messsage :initarg :message  :reader message  :initform "Undefined Condition"))
+  (:report (lambda (condition stream)
+			 (format stream "mp4-atom condition at location: <~a> with object: <~a>: message: <~a>"
+					 (location condition) (object condition) (message condition)))))
+(defmethod print-object ((me mp4-atom-condition) stream)
+  (format stream "location: <~a>, object: <~a>, message: <~a>" (location me) (object me) (message me)))
+
+(defmethod  as-string ((atom-type integer))
+  "Given an integer representing an atom type, return the string form"
+  (with-output-to-string (s nil)
+	(write-char (code-char (ldb (byte 8 24) atom-type)) s)
+	(write-char (code-char (ldb (byte 8 16) atom-type)) s)
+	(write-char (code-char (ldb (byte 8 8)  atom-type)) s)
+	(write-char (code-char (ldb (byte 8 0)  atom-type)) s)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun as-octet (c)
+	"Used below so that we can create atom 'types' from char/ints"
+	(cond ((typep c 'standard-char) (coerce (char-code c) '(unsigned-byte 8)))
+		  ((typep c 'integer) (coerce c '(unsigned-byte 8)))
+		  (t (error "can any handle characters and integers"))))
+
+  (defmacro mk-mp4-atom-type (l1 l2 l3 l4)
+	"Given 4 chars/ints, create a 32-bit word representing an atom 'type' (aka name)"
+	`(let ((retval 0))
+	   (setf (ldb (byte 8 24) retval) ,(as-octet l1))
+	   (setf (ldb (byte 8 16) retval) ,(as-octet l2))
+	   (setf (ldb (byte 8 8) retval)  ,(as-octet l3))
+	   (setf (ldb (byte 8 0) retval)  ,(as-octet l4))
+	   retval))
+
+  (defconstant +m4-ftyp+             (mk-mp4-atom-type #\f #\t #\y #\p)
+	"This should be the first atom type found in file")
+
+  (defconstant +itunes-ilst-data+      (mk-mp4-atom-type #\d #\a #\t #\a)
+	"Carries the actual data under an ilst atom")
+
+  (defconstant +itunes-lyrics+         (mk-mp4-atom-type #xa9 #\l #\y #\r)) ; text
+  (defconstant +itunes-copyright+	   (mk-mp4-atom-type #\c  #\p #\r #\t)) ; text
+  (defconstant +itunes-album+          (mk-mp4-atom-type #xa9 #\a #\l #\b)) ; text
+  (defconstant +itunes-artist+         (mk-mp4-atom-type #xa9 #\A #\R #\T)) ; text
+  (defconstant +itunes-comment+        (mk-mp4-atom-type #xa9 #\c #\m #\t)) ; text
+  (defconstant +itunes-compilation+    (mk-mp4-atom-type #\c  #\p #\i #\l)) ; byte/boolean
+  (defconstant +itunes-composer+       (mk-mp4-atom-type #xa9 #\c #\o #\m)) ; text
+  (defconstant +itunes-cover-art+      (mk-mp4-atom-type #\c  #\o #\v #\r)) ; octets
+  (defconstant +itunes-year+           (mk-mp4-atom-type #xa9 #\d #\a #\y)) ; text
+  (defconstant +itunes-disk+           (mk-mp4-atom-type #\d  #\i #\s #\k)) ; octets
+  (defconstant +itunes-tool+           (mk-mp4-atom-type #xa9 #\t #\o #\o)) ; text
+  (defconstant +itunes-genre+		   (mk-mp4-atom-type #\g  #\n #\r #\e)) ; octet
+  (defconstant +itunes-genre-x+		   (mk-mp4-atom-type #xa9 #\n #\r #\e)) ; text
+  (defconstant +itunes-groups+         (mk-mp4-atom-type #xa9 #\g #\r #\p)) ; text
+  (defconstant +itunes-title+          (mk-mp4-atom-type #xa9 #\n #\a #\m)) ; text
+  (defconstant +itunes-tempo+          (mk-mp4-atom-type #\t  #\m #\p #\o)) ; octet
+  (defconstant +itunes-track+          (mk-mp4-atom-type #xa9 #\t #\r #\k)) ; octet
+  (defconstant +itunes-track-n+        (mk-mp4-atom-type #\t  #\r #\k #\n)) ; octet
+  (defconstant +itunes-writer+         (mk-mp4-atom-type #xa9 #\w #\r #\t)) ; text
+  (defconstant +itunes-encoder+        (mk-mp4-atom-type #xa9 #\e #\n #\c)) ; text
+  (defconstant +itunes-album-artist+   (mk-mp4-atom-type #\a  #\A #\R #\T)) ; text
+  (defconstant +itunes-purchased-date+ (mk-mp4-atom-type #\p  #\u #\r #\d)) ; text
+
+  (defparameter *itunes-text-atom-types*
+	(list
+	 +itunes-album+
+	 +itunes-album-artist+
+	 +itunes-artist+
+	 +itunes-comment+
+	 +itunes-composer+
+	 +itunes-copyright+
+	 +itunes-year+
+	 +itunes-encoder+
+	 +itunes-groups+
+	 +itunes-genre-x+
+	 +itunes-lyrics+
+	 +itunes-purchased-date+
+	 +itunes-title+
+	 +itunes-tool+
+	 +itunes-writer+)
+	"These are all the itunes atoms that are stored as text")
+
+  (defparameter *itunes-atom-types*
+	(append *itunes-text-atom-types*
+			(list
+			 +itunes-compilation+
+			 +itunes-cover-art+
+			 +itunes-disk+
+			 +itunes-genre+
+			 +itunes-tempo+
+			 +itunes-track+
+			 +itunes-track-n+))
+	"The iTunes atom types we can decode")
+
+  (defconstant +mp4-atom-moov+ (mk-mp4-atom-type #\m #\o #\o #\v))
+  (defconstant +mp4-atom-udta+ (mk-mp4-atom-type #\u #\d #\t #\a))
+  (defconstant +mp4-atom-mdia+ (mk-mp4-atom-type #\m #\d #\i #\a))
+  (defconstant +mp4-atom-meta+ (mk-mp4-atom-type #\m #\e #\t #\a))
+  (defconstant +mp4-atom-ilst+ (mk-mp4-atom-type #\i #\l #\s #\t))
+
+  (defparameter *atoms-of-interest*
+	(list +mp4-atom-moov+
+		  +mp4-atom-udta+
+		  +mp4-atom-mdia+
+		  +mp4-atom-meta+
+		  +mp4-atom-ilst+)
+	"For these container atoms, we look inside these atoms to read nested atoms")
+
+  (defparameter *tag-path* (list +mp4-atom-moov+ +mp4-atom-udta+ +mp4-atom-meta+ +mp4-atom-ilst+)
+	"The 'path' of nested atoms at which tag data can be found.")
+
+  (defgeneric decode-ilst-data-atom (type atom atom-parent-type mp4-file))
+
+  (defmacro generate-generic-text-methods ()
+	"generate the decode methods for text atoms"
+	(let ((methods))
+	  (dolist (type *itunes-text-atom-types*)
+		(push `(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql ,type)) mp4-file)
+				 (read-string mp4-file :size (- (atom-size atom) 16))) methods))
+	  `(progn ,@methods)))
+  )
+
+(generate-generic-text-methods)
+
+(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql +itunes-disk+)) mp4-file)
+  "decode itunes DISK atom"
+  (declare (ignore atom))
+  (read-u16 mp4-file)					; throw away
+  (let ((a) (b))
+	(setf a (read-u16 mp4-file))
+	(setf b (read-u16 mp4-file))
+	(list a b)))
+
+(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql +itunes-track+)) mp4-file)
+  "decode itunes TRK atom"
+  (declare (ignore atom))
+  (read-u16 mp4-file)					; throw away
+  (let ((a) (b))
+	(setf a (read-u16 mp4-file))
+	(setf b (read-u16 mp4-file))
+	(read-u16 mp4-file)					; throw away
+	(list a b)))
+
+(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql +itunes-track-n+)) mp4-file)
+  "decode itunes TRKN atom"
+  (declare (ignore atom))
+  (read-u16 mp4-file)					; throw away
+  (let ((a) (b))
+	(setf a (read-u16 mp4-file))
+	(setf b (read-u16 mp4-file))
+	(read-u16 mp4-file)					; throw away
+	(list a b)))
+
+(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql +itunes-tempo+)) mp4-file)
+  "decode itunes TMPO atom"
+  (declare (ignore atom))
+  (read-u16 mp4-file))
+
+(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql +itunes-genre+)) mp4-file)
+  "decode itunes GNRE atom"
+  (declare (ignore atom))
+  (read-u16 mp4-file))
+
+(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql +itunes-compilation+)) mp4-file)
+  "decode itunes CPIL atom"
+  (declare (ignore atom))
+  (read-u8 mp4-file))
+
+(defmethod decode-ilst-data-atom ((type (eql +itunes-ilst-data+)) atom (atom-parent-type (eql +itunes-cover-art+)) mp4-file)
+  (let ((blob (make-instance 'mp4-unhandled-data)))
+	(setf (slot-value blob 'blob) (read-octets mp4-file (- (atom-size atom) 16)))
+	blob))
+
+
+(defclass mp4-atom ()
+  ((atom-file-position :accessor atom-file-position :initarg :atom-file-position)
+   (atom-size :accessor atom-size :initarg :atom-size)
+   (atom-type :accessor atom-type :initarg :atom-type)
+   (atom-children :accessor atom-children :initform (make-mp4-atom-collection)))
+  (:documentation "The minimal mp4-atom.  Note: not all atoms have children, but we put them here anyway to make things 'simple'"))
+
+(defclass mp4-ilst-atom (mp4-atom)
+  ())
+
+(defmethod initialize-instance :after ((me mp4-ilst-atom) &key (mp4-file nil) &allow-other-keys)
+  "Construct an ilst atom"
+  (log5:with-context "mp4-ilst-atom-initializer"
+	(assert (not (null mp4-file)) () "Must pass a stream into this method")
+	(with-slots (atom-size atom-type atom-children) me
+	  (let* ((start (seek mp4-file 0 :current))
+			 (end (+ start (- atom-size 8))))
+		(log-mp4-atom "mp4-ilst-atom-initializer:entry, start = ~:d, end = ~:d" start end)
+		(do* ()
+			 ((>= (seek mp4-file 0 :current) end))
+		  (log-mp4-atom "ilst atom top of loop: start = ~:d, current = ~:d, end = ~:d"
+						start (seek mp4-file 0 :current) end)
+		  (let ((child (make-mp4-atom mp4-file atom-type)))
+			 (log-mp4-atom "adding new child ~a" (vpprint child nil))
+			 (add atom-children child)))))
+	 (log-mp4-atom "Returning ilst atom: ~a" (vpprint me nil))))
+
+ (defclass mp4-ilst-generic-data-atom (mp4-atom)
+   ((atom-version :accessor atom-version :initarg :atom-version)
+	(atom-flags   :accessor atom-flags   :initarg :atom-flags)
+	(atom-value   :accessor atom-value   :initarg :atom-value)
+	(atom-parent-type  :accessor atom-parent-type  :initarg :atom-parent-type :initform nil))
+   (:documentation   "Represents the 'data' portion of ilst data atom"))
+
+ (defmethod initialize-instance :after ((me mp4-ilst-generic-data-atom) &key mp4-file &allow-other-keys)
+   (log5:with-context "mp4-ilst-generic-data-atom-initializer"
+	 (assert (not (null mp4-file)) () "Must pass a stream into this method")
+	 (log-mp4-atom "mp4-ilst-generic-data-atom-initializer:entry")
+	 (with-slots (atom-size atom-type atom-version atom-flags atom-value atom-parent-type) me
+	   (setf atom-version (read-u8 mp4-file))
+	   (setf atom-flags (read-u24 mp4-file))
+	   (if (= atom-type +itunes-ilst-data+)
+		   (assert (= 0 (read-u32 mp4-file)) () "a data atom lacks the required null field"))
+	   (log-mp4-atom "size = ~:d, name = ~a, version = ~d, flags = ~x"
+					 atom-size (as-string atom-type) atom-version atom-flags)
+	   (setf atom-value (decode-ilst-data-atom atom-type me atom-parent-type mp4-file))
+	   (log-mp4-atom "generic atom: ~a" (vpprint me nil)))))
+
+(defclass mp4-container-atom (mp4-atom)
+  ()
+  (:documentation "The class representing an mp4 container atom"))
+
+(defmethod initialize-instance :after ((me mp4-container-atom) &key (mp4-file nil) &allow-other-keys)
+  "Upon initializing a container mp4 atom, read the nested atoms within it.'"
+  (log5:with-context "mp4-container-atom-initializer"
+	(assert (not (null mp4-file)) () "Must pass a stream into this method")
+
+	(log-mp4-atom "mp4-container-atom-initializer")
+	(with-slots (atom-children atom-file-position atom-of-interest atom-size atom-type atom-decoded) me
+
+	  (log-mp4-atom "entry: starting file position = ~:d, atom ~a" atom-file-position (vpprint me nil))
+	  (log-mp4-atom "type ~a is container atom of interest; read the nested atoms" (as-string atom-type))
+	  (cond ((= atom-type +mp4-atom-meta+)
+			 (log-mp4-atom "got META, moving file position forward 4 bytes") ;null field
+			 (seek mp4-file 4 :current)))
+
+	  ;; we are now at the file-position we are need to be at, so start reading those atoms!
+	  (block read-file
+		(log-mp4-atom "starting read-file block with file-position = ~:d and end = ~:d" atom-file-position (+ atom-file-position atom-size))
+		(do ()
+			((>= (seek mp4-file 0 :current) (+ atom-file-position atom-size)))
+		  (log-mp4-atom "Top of loop: currently at file-position ~:d (reading up to ~:d)" (seek mp4-file 0 :current) (+ atom-file-position atom-size))
+		  (let ((child (make-mp4-atom mp4-file)))
+			(log-mp4-atom "adding new child ~a" (vpprint child nil))
+			(add atom-children child))))
+	  (log-mp4-atom "ended read-file block, file position now ~:d" (seek mp4-file 0 :current)))))
+
+(defun make-mp4-atom (mp4-file &optional atom-parent-type)
+  "Get current file position, read in size/type, then construct the correct atom.
+ If type is an ilst type, read it all it.  If it is a container atom of interest,
+ leave file position as is, since caller will want to read in nested atoms.  Otherwise,
+ seek forward past end of this atom."
+  (log5:with-context "make-mp4-atom"
+	(let* ((pos (seek mp4-file 0 :current))
+		   (siz (read-u32 mp4-file))
+		   (typ (read-u32 mp4-file))
+		   (atom))
+	  (declare (type integer pos siz typ))
+	  (when (= 0 siz)
+		(warn "trying to make an atom ~a with size of 0 at offset ~:d in ~a, ammending size to be 8" (as-string typ) pos (filename mp4-file))
+		(setf siz 8))
+	  (log-mp4-atom "pos = ~:d, size = ~:d, type = ~a" pos siz (as-string typ))
+	  (cond ((member typ *atoms-of-interest*)
+			 (log-mp4-atom  "~a is a container atom we are interested in" (as-string typ))
+			 (setf atom (make-instance 'mp4-container-atom :atom-size siz :atom-type typ :atom-file-position pos :mp4-file mp4-file)))
+			((member typ *itunes-atom-types*)
+			 (log-mp4-atom "~a is an ilst atom, read it all in" (as-string typ))
+			 (setf atom (make-instance 'mp4-ilst-atom :atom-size siz :atom-type typ :atom-file-position pos :mp4-file mp4-file)))
+			((= typ +itunes-ilst-data+)
+			 (log-mp4-atom "~a is an ilst data atom, read it all in" (as-string typ))
+			 (setf atom (make-instance 'mp4-ilst-generic-data-atom :atom-parent-type atom-parent-type :atom-size siz :atom-type typ :atom-file-position pos :mp4-file mp4-file)))
+			(t
+			 (log-mp4-atom "~a is an atom we are NOT interested in; seek past it" (as-string typ))
+			 (setf atom (make-instance 'mp4-atom :atom-size siz :atom-type typ :atom-file-position pos))
+			 (seek mp4-file (- siz 8) :current)))
+	  (log-mp4-atom "returning ~a" (vpprint atom nil))
+	  atom)))
+
+(defparameter *pprint-mp4-atom* nil
+  "Controls whether we pretty print an atom")
+
+(defmethod print-object ((me mp4-atom) stream)
+  (if (null *pprint-mp4-atom*)
+	  (call-next-method)
+	  ;; else
+	  (format stream "~a" (with-output-to-string (s)
+							(with-slots (atom-children atom-file-position atom-size atom-type) me
+							  (format s "Atom <~a> @ ~:d of size ~:d with ~d children"
+									  (as-string atom-type) atom-file-position atom-size (size atom-children)))
+							(if (typep me 'mp4-ilst-generic-data-atom)
+								(with-slots (atom-version atom-flags atom-value atom-type atom-parent-type) me
+								  (format s " having ilst fields: atom-parent-type = ~a, verison = ~d, flags = ~x, data = ~x"
+										  (as-string atom-parent-type) atom-version atom-flags atom-value)))))))
+
+(defmethod vpprint ((me mp4-atom) stream &key (indent 0))
+  "set *pprint-mp4-atom* to get pretty printing and call print-object via format"
+  (let ((*pprint-mp4-atom* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+(defclass mp4-unhandled-data ()
+  ((blob :accessor blob :initarg :blob :initform nil))
+  (:documentation "abstraction for a 'blob' of data we don't want to or can't parse"))
+
+(defparameter *pprint-max-array-len* 10
+  "Controls how long an array (atom-value, typically) we will print in pprint-atom")
+
+(defmethod print-object ((me mp4-unhandled-data) stream)
+  "Print a 'blob' (unstructered data), limiting it to no more than *PPRINT-MAX-ARRAY-LEN* octets"
+  (let* ((len (length (slot-value me 'blob)))
+		 (print-len (min len *pprint-max-array-len*))
+		 (printable-array (make-array print-len :displaced-to (slot-value me 'blob))))
+	(format stream "[~:d of ~:d bytes] <~x>" print-len len printable-array)))
+
+;;;;;;;;;;;;;;;;;;;; A collection of atoms (siblings) ;;;;;;;;;;;;;;;;;;;;
+(defclass atom-collection ()
+  ((atoms :accessor atoms :initform nil))
+  (:documentation "A collection of sibling atoms"))
+
+(defun make-mp4-atom-collection () (make-instance 'atom-collection))
+
+(defmethod add ((me atom-collection) new-atom)
+  "Adds new atom to the *end* (need to keep them in order we found them in the file) of this collection"
+  (log5:with-context "add-atom-collection"
+	(with-slots (atoms) me
+	  (log-mp4-atom "adding ~a to atom collection: ~a" new-atom atoms)
+	  (setf atoms (append atoms (list new-atom)))
+	  (log-mp4-atom "collection now: ~a" atoms))))
+
+(defmethod size ((me atom-collection))
+  "Returns the number of atoms in this collection"
+  (length (slot-value me 'atoms)))
+
+(defmethod map-mp4-atom ((me atom-collection) &key (func nil) (depth nil))
+  "Given a collection of atoms, call map-mp4-atom for each one"
+  (log5:with-context "map-mp4-atom(collection)"
+	(log-mp4-atom "mapping collection: ~a" (slot-value me 'atoms))
+	(dolist (a (slot-value me 'atoms))
+	  (map-mp4-atom a :func func :depth depth))))
+
+(defun is-valid-m4-file (mp4-file)
+  "Make sure this is an MP4 file.  Quick check: is first atom (at file-offset 4) == FSTYP?"
+  (seek mp4-file 0 :start)
+  (let* ((size (read-u32 mp4-file))
+		 (header (read-u32 mp4-file)))
+	(declare (ignore size))
+	(seek mp4-file 0 :start)
+	(= header +m4-ftyp+)))
+
+(defun find-mp4-atoms (mp4-file)
+  "Given a valid MP4 file mp4-file, look for the 'right' atoms and return them.
+The 'right' atoms are those in *atoms-of-interest*"
+  (log5:with-context "find-mp4-atoms"
+	(when (not (is-valid-m4-file mp4-file))
+	  (error 'mp4-atom-condition :location "find-mp4-atoms" :object (filename mp4-file) :message "is not an mp4-file" ))
+
+	(let ((atom-collection (make-mp4-atom-collection))
+		  (new-atom))
+
+	  (log-mp4-atom "before read-file loop, file-position = ~:d, end = ~:d" (seek mp4-file 0 :current) (file-size mp4-file))
+	  (block read-file
+		(do ()
+			((> (+ 8 (seek mp4-file 0 :current)) (file-size mp4-file)))
+		  (log-mp4-atom "top of read-file loop, current file-position = ~:d, end = ~:d" (seek mp4-file 0 :current) (file-size mp4-file))
+		  (setf new-atom (make-mp4-atom mp4-file))
+		  (add atom-collection new-atom)))
+	  (log-mp4-atom "returning atom-collection of size ~d" (size atom-collection))
+	  atom-collection)))
+
+(defmethod map-mp4-atom ((me mp4-atom) &key (func nil) (depth nil))
+  "traverse all atoms under a given atom"
+  (log5:with-context "map-mp4-atom(single)"
+	(labels ((_indented-atom (atom depth)
+			   (format t "~a~%" (vpprint atom nil :indent (if (null depth) 0 depth)))))
+	  (with-slots (atom-type atom-children) me
+		(log-mp4-atom "Begining traversal with ~a, I have ~d children" (as-string atom-type) (size atom-children))
+		(when (null func)
+		  (setf func #'_indented-atom))
+		(funcall func me depth)
+		(map-mp4-atom atom-children :func func :depth (if (null depth) nil (+ 1 depth)))))))
+
+(defmethod traverse ((me mp4-atom) path)
+  "Used in finding nested atoms.
+Given an atom and a path, if atom-type matches first element of path, then we've found our match."
+  (log5:with-context "traverse-atom"
+	(log-mp4-atom "traverse-atom entered with ~a ~a" (atom-type me) path)
+	(cond ((null path)
+		   (error "Path exhausted in travese atom")	; don't think this can happen?
+		   nil)
+		  ((= (atom-type me) (first path))
+		   (log-mp4-atom "current path matches thus far ~a ~a" (atom-type me) path)
+		   (cond
+			 ((= 1 (length path))
+			  (log-mp4-atom "length of path is 1, so found!")
+			  (return-from traverse me)))))
+
+	(log-mp4-atom "Current path doesn't match ~a ~a" (atom-type me) path)
+	nil))
+
+(defmethod traverse ((me atom-collection) path)
+  "Used in finding nested atoms. Seach the collection and if we find a match with first of path,
+call traverse atom (unless length of path == 1, in which case, we've found out match)"
+  (log5:with-context "traverse-atom-collection"
+	(log-mp4-atom "entering with ~a ~a" me path)
+	(dolist (sibling (atoms me))	; cleaner than using map-mp4-atom, but still a kludge
+	  (with-slots (atom-type atom-children) sibling
+		(log-mp4-atom "looking at ~x::~x" atom-type (first path))
+		(when (= atom-type (first path))
+		  (cond
+			((= 1 (length path))
+			 (log-mp4-atom "Found ~a" sibling)
+			 (return-from traverse sibling))
+			(t
+			 (log-mp4-atom "path matches, calling traverse atom with ~a, ~a" atom-children (rest path))
+			 (let ((found (traverse atom-children (rest path))))
+			   (if found (return-from traverse found))))))))
+	(log-mp4-atom "Looked at all, found nothing")
+	nil))
+
+(defmethod tag-get-value (atoms node)
+  "Helper function to extract text from atom's data atom"
+  (let ((atom (traverse atoms
+						(list +mp4-atom-moov+ +mp4-atom-udta+ +mp4-atom-meta+ +mp4-atom-ilst+ node +itunes-ilst-data+))))
+	(if atom
+		(atom-value atom)
+		nil)))

mp4-file.lisp

@@ -0,0 +1,27 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: MP4-FILE; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+(in-package #:mp4-file)
+
+(log5:defcategory cat-log-mp4-file)
+(defmacro log-mp4-file (&rest log-stuff) `(log5:log-for (cat-log-mp4-file) ,@log-stuff))
+
+(defclass mp4-file (base-file:base-file)
+  ((atoms :accessor atoms :initform nil))
+  (:documentation "Class to access m4a/mp4 files"))
+
+(defun make-mp4-file (filename read-only &key)
+  "Convenience function to create an instance of MP4-FILE with appropriate init args"
+  (log5:with-context "make-mp4-file"
+	(log-mp4-file "opening ~a" filename)
+	(let (handle)
+	  (handler-case 
+		  (progn
+			(setf handle (make-instance 'mp4-file :filename filename :endian :big-endian :read-only read-only))
+			(with-slots (atoms) handle
+			  (log-mp4-file "getting atoms")
+			  (setf atoms (mp4-atom:find-mp4-atoms handle))))
+		(condition (c)
+		  (warn "make-mp4-file got condition: ~a" c)
+		  (when handle (base-file:close-audio-file handle))
+		  (setf handle nil)))
+	  handle)))

mp4-tag.lisp

@@ -0,0 +1,80 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: MP4-TAG; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+(in-package #:mp4-tag)
+
+(defmethod album ((me mp4-file:mp4-file))          (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-album+))
+(defmethod album-artist ((me mp4-file:mp4-file))   (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-album-artist+))
+(defmethod artist ((me mp4-file:mp4-file))         (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-artist+))
+(defmethod comment ((me mp4-file:mp4-file))        (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-comment+))
+(defmethod composer ((me mp4-file:mp4-file))       (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-composer+))
+(defmethod copyright ((me mp4-file:mp4-file))      (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-copyright+))
+(defmethod year ((me mp4-file:mp4-file))           (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-year+))
+(defmethod encoder ((me mp4-file:mp4-file))        (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-encoder+))
+(defmethod groups ((me mp4-file:mp4-file))         (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-groups+))
+(defmethod lyrics ((me mp4-file:mp4-file))         (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-lyrics+))
+(defmethod purchased-date ((me mp4-file:mp4-file)) (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-purchased-date+))
+(defmethod title ((me mp4-file:mp4-file))          (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-title+))
+(defmethod tool ((me mp4-file:mp4-file))           (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-tool+))
+(defmethod writer ((me mp4-file:mp4-file))         (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-writer+))
+
+(defmethod compilation ((me mp4-file:mp4-file))    (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-compilation+))
+(defmethod disk  ((me mp4-file:mp4-file))          (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-disk+))
+(defmethod tempo ((me mp4-file:mp4-file))          (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-tempo+))
+(defmethod genre ((me mp4-file:mp4-file))
+  (let ((genre   (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-genre+))
+		(genre-x (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-genre-x+)))
+	(assert (not (and genre genre-x)))
+	(cond
+	  (genre (tag:get-genre-text genre))
+	  (genre-x (tag:get-genre-text genre-x))
+	  (t nil))))
+
+(defmethod track ((me mp4-file:mp4-file))
+  (let ((track   (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-track+))
+		(track-n (mp4-atom:tag-get-value (mp4-file:atoms me) mp4-atom:+itunes-track-n+)))
+	(assert (not (and track track-n)))
+	(if track
+		track
+		track-n)))
+
+(defmethod show-tags ((me mp4-file:mp4-file))
+  "Show the understood tags for MP4-FILE"
+  (format t "~a~%" (base-file:filename me))
+  (let ((album (album me))
+		(album-artist (album-artist me))
+		(artist (artist me))
+		(comment (comment me))
+		(compilation (compilation me))
+		(composer (composer me))
+		(copyright (copyright me))
+		(disk (disk me))
+		(encoder (encoder me))
+		(genre (genre me))
+		(groups (groups me))
+		(lyrics (lyrics me))
+		(purchased-date (purchased-date me))
+		(tempo (tempo me))
+		(title (title me))
+		(tool (tool me))
+		(track (track me))
+		(writer (writer me))
+		(year (year me)))
+	(when album (format t "~4talbum: ~a~%" album))
+	(when album-artist (format t "~4talbum-artist: ~a~%" album-artist))
+	(when artist (format t "~4tartist: ~a~%" artist))
+	(when comment (format t "~4tcomment: ~a~%" comment))
+	(format t "~4tcompilation: ~a~%" compilation)
+	(when composer (format t "~4tcomposer: ~a~%" composer))
+	(when copyright (format t "~4tcopyright: ~a~%" copyright))
+	(when disk (format t "~4tdisk: ~a~%" disk))
+	(when encoder (format t "~4tencoder: ~a~%" encoder))
+	(when genre (format t "~4tgenre: ~a~%" genre))
+	(when groups (format t "~4tgroups: ~a~%" groups))
+	(when lyrics (format t "~4tlyrics: ~a~%" lyrics))
+	(when purchased-date (format t "~4tpurchased date: ~a~%" purchased-date))
+	(when tempo (format t "~4ttempo: ~a~%" tempo))
+	(when title (format t "~4ttitle: ~a~%" title))
+	(when tool (format t "~4ttool: ~a~%" tool))
+	(when track (format t "~4ttrack: ~a~%" track))
+	(when writer (format t "~4twriter: ~a~%" writer))
+	(when year (format t "~4tyear: ~a~%" year))))

packages.lisp

@@ -0,0 +1,67 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: CL-USER; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+(in-package #:cl-user)
+
+(defpackage #:base-file
+  (:export #:close-audio-file #:octets #:make-octets #:base-file
+		   #:filename #:instream #:file-size #:endian
+		   #:read-u8 #:read-u16 #:read-u24 #:read-u32
+		   #:read-string #:read-octets #:seek)
+  (:use #:common-lisp #:binary-types))
+
+(defpackage #:mp4-file
+  (:export #:mp4-file #:make-mp4-file #:atoms)
+  (:use #:common-lisp))
+
+(defpackage #:mp3-file
+  (:export #:mp3-file #:make-mp3-file #:header #:read-sync-safe-u32)
+  (:use #:common-lisp))
+
+(defpackage #:mp4-atom
+  (:export #:mp4-atom #:map-mp4-atom #:find-mp4-atoms #:traverse #:mp4-atom-condition
+		   #:atom-file-position #:atom-children #:atom-size #:atom-of-interest #:atom-decoded
+		   #:atom-type #:vpprint #:*tag-path* #:tag-get-value
+		   #:+itunes-album+
+		   #:+itunes-album-artist+
+		   #:+itunes-artist+
+		   #:+itunes-comment+
+		   #:+itunes-composer+
+		   #:+itunes-copyright+
+		   #:+itunes-year+
+		   #:+itunes-encoder+
+		   #:+itunes-groups+
+		   #:+itunes-lyrics+
+		   #:+itunes-purchased-date+
+		   #:+itunes-title+
+		   #:+itunes-tool+
+		   #:+itunes-writer+
+		   #:+itunes-compilation+
+		   #:+itunes-cover-art+
+		   #:+itunes-disk+
+		   #:+itunes-genre+
+		   #:+itunes-genre-x+
+		   #:+itunes-tempo+
+		   #:+itunes-track+
+		   #:+itunes-track-n+)
+  (:use #:common-lisp #:binary-types #:base-file))
+
+(defpackage :mp3-frame
+  (:export :mp3-frame #:find-mp3-frames #:mp3-frame-condition #:vpprint #:header)
+  (:use :common-lisp :binary-types :base-file))
+
+(defpackage :mp3-tag
+  (:export :show-tags)
+  (:use :common-lisp :binary-types :base-file))
+
+(defpackage #:tag
+  (:export #:get-genre-text)
+  (:use #:common-lisp))
+
+(defpackage #:mp4-tag
+  (:export #:show-tags #:album #:album-artist #:artist #:comment #:composer #:copyright #:created
+		   #:encoder #:groups #:lyrics #:purd #:title #:tool #:writer)
+  (:use #:common-lisp))
+
+(defpackage #:logging
+  (:export #:with-logging)
+  (:use #:common-lisp))

tag.lisp

@@ -0,0 +1,57 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: TAG; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+(in-package #:tag)
+
+;;;
+;;; From Practical Common Lisp be Peter Seibel
+;;;
+(defparameter *id3-v1-genres*
+  #(
+    ;; These are the official ID3v1 genres.
+    "Blues" "Classic Rock" "Country" "Dance" "Disco" "Funk" "Grunge"
+    "Hip-Hop" "Jazz" "Metal" "New Age" "Oldies" "Other" "Pop" "R&B" "Rap"
+    "Reggae" "Rock" "Techno" "Industrial" "Alternative" "Ska"
+    "Death Metal" "Pranks" "Soundtrack" "Euro-Techno" "Ambient"
+    "Trip-Hop" "Vocal" "Jazz+Funk" "Fusion" "Trance" "Classical"
+    "Instrumental" "Acid" "House" "Game" "Sound Clip" "Gospel" "Noise"
+    "AlternRock" "Bass" "Soul" "Punk" "Space" "Meditative"
+    "Instrumental Pop" "Instrumental Rock" "Ethnic" "Gothic" "Darkwave"
+    "Techno-Industrial" "Electronic" "Pop-Folk" "Eurodance" "Dream"
+    "Southern Rock" "Comedy" "Cult" "Gangsta" "Top 40" "Christian Rap"
+    "Pop/Funk" "Jungle" "Native American" "Cabaret" "New Wave"
+    "Psychadelic" "Rave" "Showtunes" "Trailer" "Lo-Fi" "Tribal"
+    "Acid Punk" "Acid Jazz" "Polka" "Retro" "Musical" "Rock & Roll"
+    "Hard Rock"
+
+    ;; These were made up by the authors of Winamp but backported into
+    ;; the ID3 spec.
+    "Folk" "Folk-Rock" "National Folk" "Swing" "Fast Fusion"
+    "Bebob" "Latin" "Revival" "Celtic" "Bluegrass" "Avantgarde"
+    "Gothic Rock" "Progressive Rock" "Psychedelic Rock" "Symphonic Rock"
+    "Slow Rock" "Big Band" "Chorus" "Easy Listening" "Acoustic" "Humour"
+    "Speech" "Chanson" "Opera" "Chamber Music" "Sonata" "Symphony"
+    "Booty Bass" "Primus" "Porn Groove" "Satire" "Slow Jam" "Club"
+    "Tango" "Samba" "Folklore" "Ballad" "Power Ballad" "Rhythmic Soul"
+    "Freestyle" "Duet" "Punk Rock" "Drum Solo" "A capella" "Euro-House"
+    "Dance Hall"
+
+    ;; These were also invented by the Winamp folks but ignored by the
+    ;; ID3 authors.
+    "Goa" "Drum & Bass" "Club-House" "Hardcore" "Terror" "Indie"
+    "BritPop" "Negerpunk" "Polsk Punk" "Beat" "Christian Gangsta Rap"
+    "Heavy Metal" "Black Metal" "Crossover" "Contemporary Christian"
+    "Christian Rock" "Merengue" "Salsa" "Thrash Metal" "Anime" "Jpop"
+    "Synthpop"))
+
+
+(defmacro safe-aref (arry index)
+  `(handler-case (aref ,arry ,index)
+	 (condition (c)
+	   (declare (ignore c))
+	   "N/A")))
+
+(defmethod get-genre-text ((genre string))
+  (safe-aref *id3-v1-genres* (parse-integer genre :start 1 :junk-allowed t)))
+
+(defmethod get-genre-text ((genre integer))
+  (safe-aref *id3-v1-genres* (- genre 1)))

taglib-tests.asd

@@ -0,0 +1,9 @@
+;;; taglib-tests.asd
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+;;;
+(asdf:defsystem #:taglib-tests
+  :description "Simple demo/test code for taglib"
+  :author "Mark VandenBrink"
+  :license "Public Domain"
+  :depends-on (#:taglib #:osicat)
+  :components ((:file "taglib-tests")))

taglib-tests.lisp

@@ -0,0 +1,75 @@
+;;; -*- Mode: Lisp;  show-trailing-whitespace: t; Base: 10; indent-tabs: nil; Syntax: ANSI-Common-Lisp; Package: TAGLIB-TESTS; -*-
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+(in-package #:cl-user)
+
+(defpackage #:taglib-tests
+  (:use #:common-lisp #:logging))
+
+(in-package #:taglib-tests)
+
+(defparameter *song-m4a* "01 Keep Yourself Alive.m4a")
+(defparameter *song-mp3* "02 You Take My Breath Away.mp3")
+
+(defun set-pathname-encoding (enc)
+  (setf (ccl:pathname-encoding-name) enc))
+(defun set-pathname-encoding-for-osx ()
+  (set-pathname-encoding :utf-8))
+(defun set-pathname-encoding-for-linux ()
+  (set-pathname-encoding nil))
+
+(defmethod has-extension ((n string) ext)
+  (has-extension (parse-namestring n) ext))
+
+(defmethod has-extension ((p pathname) ext)
+  (let ((e (pathname-type p)))
+	(if e
+	  (string= (string-downcase e) (string-downcase ext))
+	  nil)))
+
+(defmacro redirect (filename &rest body)
+  `(let ((*standard-output* (open ,filename :direction :output :if-does-not-exist :create :if-exists :overwrite)))
+	 ,@body))
+
+;;;;;;;;;;;;;;;;;;;; MP4 Tests ;;;;;;;;;;;;;;;;;;;;
+(defun mp4-test0 (file)
+  (let (foo)
+	(unwind-protect 
+		 (setf foo (mp4-file:make-mp4-file file t))
+	  (when foo (base-file:close-audio-file foo)))
+	foo))
+
+(defun mp4-test1 ()
+  (mp4-test0 *song-m4a*))
+
+(defun mp4-test2 (&key (dir "Queen"))
+  (osicat:walk-directory dir (lambda (f)
+							   (when (has-extension f "m4a")
+								 (let ((file (mp4-test0 f)))
+								   (when file (mp4-tag:show-tags file)))))))
+
+;;;;;;;;;;;;;;;;;;;; MP3 Tests ;;;;;;;;;;;;;;;;;;;;
+(defun mp3-test0 (file)
+  (let (foo)
+	(unwind-protect 
+		 (setf foo (mp3-file:make-mp3-file file t))
+	  (when foo (base-file:close-audio-file foo)))
+	foo))
+
+(defun mp3-test1 ()
+  (mp3-test0 *song-mp3*))
+
+(defun mp3-test2 (&key (dir "Queen"))
+  (osicat:walk-directory dir (lambda (f)
+							   (when (has-extension f "mp3")
+								 (let ((file (mp3-test0 f)))
+								   (when file (mp3-tag:show-tags file)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun test2 (&key (dir "Queen"))
+  (osicat:walk-directory dir (lambda (f)
+							   (if (has-extension f "mp3")
+								   (let ((file (mp3-test0 f)))
+									 (when file (mp3-tag:show-tags file)))
+								   (if (has-extension f "m4a")
+									   (let ((file (mp4-test0 f)))
+										 (when file (mp4-tag:show-tags file))))))))

taglib.asd

@@ -0,0 +1,19 @@
+;;; taglib.asd
+;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
+;;;
+(asdf:defsystem #:taglib
+  :description "Pure Lisp implementation to read (and write?) tags"
+  :author "Mark VandenBrink"
+  :license "Public Domain"
+  :depends-on (#:log5 #:binary-types #:alexandria)
+  :components ((:file "packages")
+			   (:file "tag"       :depends-on ("packages"))
+			   (:file "base-file" :depends-on ("packages"))
+			   (:file "mp3-file"  :depends-on ("packages" "base-file" "mp3-frame"))
+			   (:file "mp3-frame" :depends-on ("packages"))
+			   (:file "mp3-tag"   :depends-on ("packages" "mp3-frame" "mp3-file"))
+			   (:file "logging"   :depends-on ("packages" "mp4-atom" "mp4-file" "base-file"))
+			   (:file "mp4-atom"  :depends-on ("packages"))
+			   (:file "mp4-tag"   :depends-on ("packages"))
+			   (:file "mp4-file"  :depends-on ("packages" "base-file" "mp4-atom"))))
+