checkpoint

mp3-frame.lisp

@@ -39,11 +39,11 @@
   "Make sure this is an MP3 file. Look for frames at begining and/or end"
   (log5:with-context "is-valid-mp3-file"
 	(stream-seek mp3-file 0 :start)
-	(let* ((id3 (stream-read-string mp3-file :size 3))
+	(let* ((id3 (stream-read-string-with-len mp3-file 3))
 		   (version (stream-read-u8 mp3-file))
 		   (tag))
 	  (stream-seek mp3-file 128 :end)
-	  (setf tag (stream-read-string mp3-file :size 3))
+	  (setf tag (stream-read-string-with-len mp3-file 3))
 	  (stream-seek mp3-file 0 :start)
 
 	  (log-mp3-frame "id3 = ~a, version = ~d" id3 version)
@@ -78,11 +78,11 @@
   (log5:with-context "v21-frame-initializer"
 	(log-mp3-frame "reading v2.1 tag")
 	(with-slots (songname artist album year comment genre) me
-	  (setf songname (stream-read-string instream :size 30 :terminators '(0)))
-	  (setf artist   (stream-read-string instream :size 30 :terminators '(0)))
-	  (setf album    (stream-read-string instream :size 30 :terminators '(0)))
-	  (setf year     (stream-read-string instream :size 4  :terminators '(0)))
-	  (setf comment  (stream-read-string instream :size 30 :terminators '(0)))
+	  (setf songname (trim-string (stream-read-string-with-len instream 30)))
+	  (setf artist   (trim-string (stream-read-string-with-len instream 30)))
+	  (setf album    (trim-string (stream-read-string-with-len instream 30)))
+	  (setf year     (trim-string (stream-read-string-with-len instream 4)))
+	  (setf comment  (trim-string (stream-read-string-with-len instream 30)))
 	  (setf genre    (stream-read-u8 instream))
 	  (log-mp3-frame "v21 tag: ~a" (vpprint me nil)))))
 
@@ -93,19 +93,20 @@
    (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)))
+;; (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 stream-seek'ed to correct location in file."
+  "Read in the extended header.  Caller will have stream-seek'ed to correct location in file.
+Note: extended headers are subject to unsynchronization, so make sure that INSTREAM has been made sync-safe."
   (with-slots (size flags padding crc) me
-	(setf size (stream-read-u32 instream))
+	(setf size (stream-read-u32 instream)) ; this is sync-safe in 2.4?
 	(setf flags (stream-read-u16 instream))
-	(setf padding (stream-read-u32 instream))
+	(setf padding (stream-read-u32 instream)) ; this is sync-safe and 35 bits in 2.4?
 	(when (ext-header-crc-p flags)
 	  (setf crc (stream-read-u32 instream)))))
 
@@ -115,6 +116,10 @@
 	  (with-slots (size flags padding crc) me
 		(format stream "extended header: size: ~d, flags: ~x, padding ~:d, crc = ~x~%"
 				size flags padding crc))))
+(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 header-unsynchronized-p (flags) `(logbitp 7 ,flags))
 (defmacro header-extended-p (flags)       `(logbitp 6 ,flags))
@@ -139,43 +144,41 @@
 					(concatenate 'string "Extended header: " (vpprint ext-header nil))
 					"No extended header")
 				(if v21-tag-header
-					(concatenate 'string "V21 tag: " (vpprint v21-tag-header nil))
+					(concatenate 'string "V21 tag:" (vpprint v21-tag-header nil))
 					"No v21 tag"))
 		(when frames
-		  (format stream "~4tFrames[~d]:~%~{~8t~a~^~%~}" (length frames) 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."
+  "Fill in an mp3-header from INSTREAM."
   (log5:with-context "mp3-id3-header-initializer"
 	(with-slots (version revision flags size ext-header frames v21-tag-header) me
 	  (stream-seek instream 128 :end)
-	  (when (string= "TAG" (stream-read-string instream :size 3))
+	  (when (string= "TAG" (stream-read-string-with-len instream 3))
 		(log-mp3-frame "looking at last 128 bytes at ~:d to try to read id3v21 header" (stream-seek instream 0 :current))
 		(handler-case
 			(setf v21-tag-header (make-instance 'v21-tag-header :instream instream))
-		  (condition (c)
+		  (mp3-frame-condition (c)
 			(log-mp3-frame "reading v21 got condition: ~a" c))))
 
 	  (stream-seek instream 0 :start)
-	  (when (string= "ID3" (stream-read-string instream :size 3))
+	  (when (string= "ID3" (stream-read-string-with-len instream 3))
 		(setf version (stream-read-u8 instream))
 		(setf revision (stream-read-u8 instream))
 		(setf flags (stream-read-u8 instream))
-		(setf size (stream-read-sync-safe-u32 instream))
+		(setf size (stream-read-u32 instream :bits-per-byte 7))
 		(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))))
+		(assert (not (header-footer-p flags)) () "Can't decode ID3 footer's yet"))
 
 	  (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))
+   (version :accessor version :initarg :version)
+   (flags   :accessor flags   :initarg :flags :initform nil)) ; unused in v2.2
   (:documentation "Base class for an ID3 frame"))
 
 (defmacro frame-23-altertag-p  (frame-flags) `(logbitp 15 ,frame-flags))
@@ -202,8 +205,8 @@
 (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 "
+	  (with-slots (pos version id len flags) me
+		(format stream "@offset: ~:d, <version = ~d, id: ~s, len: ~:d "
 				pos version id len)
 		(if flags
 			(ecase version
@@ -232,36 +235,688 @@
 
 (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 (stream-seek instream 0 :current))
-	  (setf octets (stream-read-octets instream len)))))
+	(with-slots (pos len octets) me
+	  (log-mp3-frame "reading ~:d bytes from position ~:d" len pos)
+	  (setf octets (stream-read-sequence instream len))
+	  (log-mp3-frame "frame: ~a" (vpprint me nil)))))
+
+(defparameter *max-raw-bytes-print-len* 10)
+(defun printable-array (array)
+  (let* ((len (length array))
+		 (print-len (min len *max-raw-bytes-print-len*))
+		 (printable-array (make-array print-len :displaced-to array)))
+	(format nil "[~:d of ~:d bytes] <~x>" print-len len printable-array)))
+
+(defun upto-null (string)
+  (subseq string 0 (position #\Null string)))
 
 (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)))))
+		(format stream "~a" (printable-array octets)))))
+(defmethod vpprint ((me raw-frame) 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)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; V22 frames
+;;
+
+;;; frame I haven't parsed (or don't need to parse)
+(defclass frame-buf (raw-frame) ())
+(defclass frame-cnt (raw-frame) ())
+(defclass frame-cra (raw-frame) ())
+(defclass frame-crm (raw-frame) ())
+(defclass frame-equ (raw-frame) ())
+(defclass frame-etc (raw-frame) ())
+(defclass frame-geo (raw-frame) ())
+(defclass frame-ipl (raw-frame) ())
+(defclass frame-lnk (raw-frame) ())
+(defclass frame-mci (raw-frame) ())
+(defclass frame-mll (raw-frame) ())
+(defclass frame-pop (raw-frame) ())
+(defclass frame-rev (raw-frame) ())
+(defclass frame-rva (raw-frame) ())
+(defclass frame-slt (raw-frame) ())
+(defclass frame-ult (raw-frame) ())
+(defclass frame-waf (raw-frame) ())
+(defclass frame-war (raw-frame) ())
+(defclass frame-was (raw-frame) ())
+(defclass frame-wcm (raw-frame) ())
+(defclass frame-wcp (raw-frame) ())
+(defclass frame-wpb (raw-frame) ())
+(defclass frame-wxx (raw-frame) ())
+(defclass frame-stc (raw-frame) ())
+
+;; COM frames
+;; Comment                   "COM"
+;; Frame size                $xx xx xx
+;; Text encoding             $xx
+;; Language                  $xx xx xx
+;; Short content description <textstring> $00 (00)
+;; The actual text           <textstring>
+(defclass frame-com (id3-frame)
+  ((encoding :accessor encoding)
+   (lang     :accessor lang)
+   (desc	 :accessor desc)
+   (text	 :accessor text)))
+
+(defmethod initialize-instance :after ((me frame-com) &key instream)
+  (log5:with-context "frame-com"
+	(with-slots (len encoding lang desc text) me
+	  (setf encoding (stream-read-u8 instream))
+	  (setf lang (stream-read-iso-string-with-len instream 3))
+	  (multiple-value-bind (n v) (get-name-value-pair instream (- len 1 3) encoding encoding)
+		(setf desc n)
+		(setf text v))
+	  (log-mp3-frame "encoding = ~d, lang = <~a>, desc = <~a>, text = <~a>" encoding lang desc text))))
+
+
+(defmethod print-object :after ((me frame-com) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (len encoding lang desc text) me
+		(format stream "frame-com, encoding = ~d, lang = <~a>, desc = <~a>, text = <~a>" encoding lang desc text))))
+(defmethod vpprint ((me frame-com) stream &key (indent 0))
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+;; v22 PIC
+;; Attached picture   "PIC"
+;; Frame size         $xx xx xx
+;; Text encoding      $xx
+;; Image format       $xx xx xx
+;; Picture type       $xx
+;; Description        <textstring> $00 (00)
+;; Picture data       <binary data>
+(defclass frame-pic (id3-frame)
+  ((encoding   :accessor encoding)
+   (img-format :accessor img-format)
+   (type       :accessor type)
+   (desc       :accessor desc)
+   (data       :accessor data)))
+
+(defmethod initialize-instance :after ((me frame-pic) &key instream)
+  (log5:with-context "frame-pic"
+	(with-slots (id len encoding img-format type desc data) me
+	  (setf encoding (stream-read-u8 instream))
+	  (setf img-format (stream-read-iso-string-with-len instream 3))
+	  (setf type (stream-read-u8 instream))
+	  (multiple-value-bind (n v) (get-name-value-pair instream (- len 5) encoding -1)
+		(setf desc n)
+		(setf data v)
+		(log-mp3-frame "encoding: ~d, img-format = <~a>, type = ~d, desc = <~a>, value = ~a"
+				   encoding img-format type desc (printable-array data))))))
+
+(defmethod print-object :after ((me frame-pic) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (encoding img-format type desc data) me
+		(format stream "frame-pic: encoding ~d, img-format type: <~a>, picture type: ~d, description <~s>, data: ~a"
+				encoding img-format type desc (printable-array data)))))
+(defmethod vpprint ((me frame-pic) stream &key (indent 0))
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+;; Generic text-info frames
+;; Text information identifier  "T00" - "TZZ" , excluding "TXX", or "T000 - TZZZ", excluding "TXXX"
+;; Text encoding                $xx
+;; Information                  <textstring>
+(defclass frame-text-info (id3-frame)
+  ((encoding :accessor encoding)
+   (info     :accessor info)))
+
+(defmethod initialize-instance :after ((me frame-text-info) &key instream)
+  (log5:with-context "frame-text-info"
+	(with-slots (len encoding info) me
+	  (setf encoding (stream-read-u8 instream))
+	  (setf info (stream-read-string-with-len instream (1- len) :encoding encoding))
 
+	  ;; a null is ok, but according to the "spec", you're supposed to ignore anything after a 'Null'
+	  (setf info (upto-null info))
+
+	  (log-mp3-frame "encoding = ~d, info = <~a>" encoding info))))
+
+(defmethod print-object :after ((me frame-text-info) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (len encoding info) me
+		(format stream "frame-text-info, encoding = ~d, info = <~a>" encoding info))))
+(defmethod vpprint ((me frame-text-info) stream &key (indent 0))
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+
+;; v22 User defined...   "TXX" frames
+;; Frame size        $xx xx xx
+;; Text encoding     $xx
+;; Description       <textstring> $00 (00)
+;; Value             <textstring>
+(defclass frame-txx (id3-frame)
+  ((encoding :accessor encoding)
+   (desc     :accessor desc)
+   (value    :accessor value)))
+
+(defmethod initialize-instance :after ((me frame-txx) &key instream)
+  (log5:with-context "frame-txx"
+	(with-slots (len encoding desc value) me
+	  (setf encoding (stream-read-u8 instream))
+	  (multiple-value-bind (n v) (get-name-value-pair instream (1- len) encoding encoding)
+		(setf desc n)
+		(setf value v)
+		(log-mp3-frame "encoding = ~d, desc = <~a>, value = <~a>" encoding desc value)))))
+
+(defmethod print-object :after ((me frame-txx) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (len encoding desc value) me
+		(format stream "frame-txx, encoding = ~d, desc = <~a>, value = <~a>" encoding desc value))))
+(defmethod vpprint ((me frame-txx) stream &key (indent 0))
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+(defclass frame-ufi (id3-frame)
+  ((name  :accessor name)
+   (value :accessor value)))
+
+(defmethod initialize-instance :after ((me frame-ufi) &key instream)
+  (log5:with-context "frame-ufi"
+	(with-slots (id len name value) me
+	  (multiple-value-bind (n v) (get-name-value-pair instream len 0 -1)
+		(setf name n)
+		(setf value v))
+	  (log-mp3-frame "name = <~a>, value = ~a" name (printable-array value)))))
+
+(defmethod print-object :after ((me frame-ufi) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (id len name value) me
+		(format stream "frame-ufi: name: <~s>, value: ~a" name (printable-array value)))))
+(defmethod vpprint ((me frame-ufi) stream &key (indent 0))
+  (let ((*pprint-mp3-frame* t))
+	(format stream "~vt~a" (* indent 1) me)))
+
+(defclass frame-tal (frame-text-info) ())
+(defclass frame-tbp (frame-text-info) ())
+(defclass frame-tcm (frame-text-info) ())
+(defclass frame-tco (frame-text-info) ())
+(defclass frame-tcp (frame-text-info) ())
+(defclass frame-tcr (frame-text-info) ())
+(defclass frame-tda (frame-text-info) ())
+(defclass frame-tdy (frame-text-info) ())
+(defclass frame-ten (frame-text-info) ())
+(defclass frame-tft (frame-text-info) ())
+(defclass frame-tim (frame-text-info) ())
+(defclass frame-tke (frame-text-info) ())
+(defclass frame-tla (frame-text-info) ())
+(defclass frame-tle (frame-text-info) ())
+(defclass frame-tmt (frame-text-info) ())
+(defclass frame-toa (frame-text-info) ())
+(defclass frame-tof (frame-text-info) ())
+(defclass frame-tol (frame-text-info) ())
+(defclass frame-tor (frame-text-info) ())
+(defclass frame-tot (frame-text-info) ())
+(defclass frame-tp1 (frame-text-info) ())
+(defclass frame-tp2 (frame-text-info) ())
+(defclass frame-tp3 (frame-text-info) ())
+(defclass frame-tp4 (frame-text-info) ())
+(defclass frame-tpa (frame-text-info) ())
+(defclass frame-tpb (frame-text-info) ())
+(defclass frame-trc (frame-text-info) ())
+(defclass frame-trd (frame-text-info) ())
+(defclass frame-trk (frame-text-info) ())
+(defclass frame-tsi (frame-text-info) ())
+(defclass frame-tss (frame-text-info) ())
+(defclass frame-tt1 (frame-text-info) ())
+(defclass frame-tt2 (frame-text-info) ())
+(defclass frame-tt3 (frame-text-info) ())
+(defclass frame-txt (frame-text-info) ())
+(defclass frame-tye (frame-text-info) ())
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; V2.3/4 frames
+
+;;
+;; <Header for 'Audio encryption', ID: "AENC"> 
+;; Owner identifier        <text string> $00
+;; Preview start           $xx xx
+;; Preview length          $xx xx
+;; Encryption info         <binary data>
+(defclass frame-aenc (raw-frame) ())
+
+(defclass frame-aspi (raw-frame) ())
+(defclass frame-comr (raw-frame) ())
+(defclass frame-encr (raw-frame) ())
+(defclass frame-equ2 (raw-frame) ())
+(defclass frame-equa (raw-frame) ())
+(defclass frame-etco (raw-frame) ())
+(defclass frame-geob (raw-frame) ())
+(defclass frame-grid (raw-frame) ())
+(defclass frame-ipls (raw-frame) ())
+(defclass frame-link (raw-frame) ())
+(defclass frame-mcdi (raw-frame) ())
+(defclass frame-mllt (raw-frame) ())
+(defclass frame-ncon (raw-frame) ())
+(defclass frame-owne (raw-frame) ())
+(defclass frame-popm (raw-frame) ())
+(defclass frame-poss (raw-frame) ())
+(defclass frame-rbuf (raw-frame) ())
+(defclass frame-rva2 (raw-frame) ())
+(defclass frame-rvad (raw-frame) ())
+(defclass frame-rvrb (raw-frame) ())
+(defclass frame-seek (raw-frame) ())
+(defclass frame-sign (raw-frame) ())
+(defclass frame-sylt (raw-frame) ())
+(defclass frame-sytc (raw-frame) ())
+(defclass frame-user (raw-frame) ())
+(defclass frame-uslt (raw-frame) ())
+
+;; APIC
+;; <Header for 'Attached picture', ID: "APIC">
+;; Text encoding   $xx
+;; MIME type       <text string> $00
+;; Picture type    $xx
+;; Description     <text string according to encoding> $00 (00)
+;; Picture data    <binary data>
+(defclass frame-apic (id3-frame)
+  ((encoding :accessor encoding)
+   (mime     :accessor mime)
+   (type     :accessor type)
+   (desc     :accessor desc)
+   (data     :accessor data)))
+
+(defmethod initialize-instance :after ((me frame-apic) &key instream)
+  (log5:with-context "frame-apic"
+	(with-slots (id len encoding mime type desc data) me
+	  (setf encoding (stream-read-u8 instream))
+	  (setf mime (stream-read-iso-string instream))
+	  (setf type (stream-read-u8 instream))
+	  (multiple-value-bind (n v) (get-name-value-pair instream (- len 1 (length mime) 1 1) encoding -1)
+		(setf desc n)
+		(setf data v)
+		(log-mp3-frame "enoding = ~d, mime = <~a>, type = ~d, descx = <~a>, data = ~a" encoding mime type desc (printable-array data))))))
+
+(defmethod print-object :after ((me frame-apic) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (encoding mime type desc data) me
+		(format stream "frame-apic: encoding ~d, mime type: ~s, picture type: ~d, description <~s>, data: ~a"
+				encoding mime type desc (printable-array data)))))
+(defmethod vpprint ((me frame-apic) 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)))
+
+;; COMM frames
+;; <Header for 'Comment', ID: "COMM">
+;; Text encoding           $xx
+;; Language                $xx xx xx
+;; Short content descrip.  <text string according to encoding> $00 (00)
+;; The actual text         <full text string according to encoding>
+(defclass frame-comm (id3-frame)
+  ((encoding :accessor encoding)
+   (lang	 :accessor lang)
+   (desc     :accessor desc)
+   (val		 :accessor val)))
+
+(defmethod initialize-instance :after ((me frame-comm) &key instream)
+  (log5:with-context "frame-comm"
+	(with-slots (encoding lang len desc val) me
+	  (setf encoding (stream-read-u8 instream))
+	  (setf lang (stream-read-iso-string-with-len instream 3))
+	  (multiple-value-bind (n v) (get-name-value-pair instream (- len 1 3) encoding encoding)
+		(setf desc n)
+		(setf val v))
+	  (log-mp3-frame "encoding = ~d, lang = <~a>, desc = <~a>, val = <~a>" encoding lang desc val))))
+
+(defmethod print-object :after ((me frame-comm) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (encoding lang desc val) me
+		(format stream "frame-comm: encoding: ~d, lang: ~x, desc: ~s, val ~s"
+				encoding lang desc val))))
+(defmethod vpprint ((me frame-comm) 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)))
+
+
+;; PCNT frames
+;; <Header for 'Play counter', ID: "PCNT">
+;; Counter         $xx xx xx xx (xx ...)
+(defclass frame-pcnt (id3-frame)
+  ((play-count :accessor play-count)))
+
+(defmethod initialize-instance :after ((me frame-pcnt) &key instream)
+  (log5:with-context "frame-pcnt"
+	(with-slots (play-count len) me
+	  (setf play-count (stream-read-sequence instream len)) ;; XXX read this as a number???
+	  (log-mp3-frame "play count = <~a>" play-count))))
+
+(defmethod print-object :after ((me frame-pcnt) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (play-count) me
+		(format stream "frame-pcnt: ~d" play-count))))
+(defmethod vpprint ((me frame-pcnt) 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)))
+
+;; PRIV frames
+;; <Header for 'Private frame', ID: "PRIV">
+;; Owner identifier        <text string> $00
+;; The private data        <binary data>
+(defclass frame-priv (id3-frame)
+  ((name  :accessor name)
+   (value :accessor value)))
+
+(defmethod initialize-instance :after ((me frame-priv) &key instream)
+  (log5:with-context "frame-priv"
+	(with-slots (id len name value) me
+	  (multiple-value-bind (n v) (get-name-value-pair instream len 0 -1)
+		(setf name n)
+		(setf value v)
+		(log-mp3-frame "name = <~a>, value = <~a>" name value)))))
+
+(defmethod print-object :after ((me frame-priv) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (id len name value) me
+		(format stream "frame-priv: name: <~s>, data: ~a" name (printable-array value)))))
+(defmethod vpprint ((me frame-priv) 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)))
+
+;; TXXX frames
+;; <Header for 'User defined text information frame', ID: "TXXX">
+;; Text encoding    $xx
+;; Description      <text string according to encoding> $00 (00)
+;; Value    	    <text string according to encoding>
+(defclass frame-txxx (id3-frame)
+  ((encoding :accessor encoding)
+   (desc     :accessor desc)
+   (value    :accessor value)))
+
+(defmethod initialize-instance :after ((me frame-txxx) &key instream)
+  (log5:with-context "frame-txxx"
+	(with-slots (encoding len desc value) me
+	  (setf encoding (stream-read-u8 instream))
+	  (multiple-value-bind (n v) (get-name-value-pair instream
+													  (- len 1)
+													  encoding
+													  encoding)
+		(setf desc n)
+		(setf value v))
+	  (log-mp3-frame "encoding = ~d, desc = <~a>, value = <~a>" encoding desc value))))
+
+(defmethod print-object :after ((me frame-txxx) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (format stream "frame-txxx: <~s/~s>" (desc me) (value me))))
+(defmethod vpprint ((me frame-txxx) 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)))
+
+
+;; UFID frames
+;; <Header for 'Unique file identifier', ID: "UFID">
+;; Owner identifier    <text string> $00
+;; Identifier    	   <up to 64 bytes binary data>
+(defclass frame-ufid (id3-frame)
+  ((name  :accessor name)
+   (value :accessor value)))
+
+(defmethod initialize-instance :after ((me frame-ufid) &key instream)
+  (log5:with-context "frame-ufid"
+	(with-slots (id len name value) me
+	  (multiple-value-bind (n v) (get-name-value-pair instream len 0 -1)
+		(setf name n)
+		(setf value v))
+	  (log-mp3-frame "name = <~a>, value = ~a" name (printable-array value)))))
+
+(defmethod print-object :after ((me frame-ufid) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (id len name value) me
+		(format stream "frame-ufid: name: <~s>, value: ~a" name (printable-array value)))))
+(defmethod vpprint ((me frame-ufid) 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)))
+
+;; URL frame
+;; <Header for 'URL link frame', ID: "W000" - "WZZZ", excluding "WXXX" described in 4.3.2.>
+;; URL <text string>
+(defclass frame-url-link (id3-frame)
+  ((url :accessor url)))
+
+(defmethod initialize-instance :after ((me frame-url-link) &key instream)
+  (with-slots (id len url) me
+	(log5:with-context "url"
+	  (setf url (stream-read-iso-string-with-len instream len))
+	  (log-mp3-frame "url = <~a>" url))))
+
+(defmethod print-object :after ((me frame-url-link) stream)
+  (if (null *pprint-mp3-frame*)
+	  (call-next-method)
+	  (with-slots (url) me
+		(format stream "frame-url-link: url: ~s" url))))
+(defmethod vpprint ((me frame-url-link) 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)))
+
+
+(defclass frame-talb (frame-text-info) ())
+(defclass frame-tbpm (frame-text-info) ())
+(defclass frame-tcmp (frame-text-info) ())
+(defclass frame-tcom (frame-text-info) ())
+(defclass frame-tcon (frame-text-info) ())
+(defclass frame-tcop (frame-text-info) ())
+(defclass frame-tdat (frame-text-info) ())
+(defclass frame-tden (frame-text-info) ())
+(defclass frame-tdly (frame-text-info) ())
+(defclass frame-tdor (frame-text-info) ())
+(defclass frame-tdrc (frame-text-info) ())
+(defclass frame-tdrl (frame-text-info) ())
+(defclass frame-tdtg (frame-text-info) ())
+(defclass frame-tenc (frame-text-info) ())
+(defclass frame-text (frame-text-info) ())
+(defclass frame-tflt (frame-text-info) ())
+(defclass frame-time (frame-text-info) ())
+(defclass frame-tipl (frame-text-info) ())
+(defclass frame-tit1 (frame-text-info) ())
+(defclass frame-tit2 (frame-text-info) ())
+(defclass frame-tit3 (frame-text-info) ())
+(defclass frame-tkey (frame-text-info) ())
+(defclass frame-tlan (frame-text-info) ())
+(defclass frame-tlen (frame-text-info) ())
+(defclass frame-tmcl (frame-text-info) ())
+(defclass frame-tmed (frame-text-info) ())
+(defclass frame-tmoo (frame-text-info) ())
+(defclass frame-toal (frame-text-info) ())
+(defclass frame-tofn (frame-text-info) ())
+(defclass frame-toly (frame-text-info) ())
+(defclass frame-tope (frame-text-info) ())
+(defclass frame-tory (frame-text-info) ())
+(defclass frame-town (frame-text-info) ())
+(defclass frame-tpe1 (frame-text-info) ())
+(defclass frame-tpe2 (frame-text-info) ())
+(defclass frame-tpe3 (frame-text-info) ())
+(defclass frame-tpe4 (frame-text-info) ())
+(defclass frame-tpos (frame-text-info) ())
+(defclass frame-tpro (frame-text-info) ())
+(defclass frame-tpub (frame-text-info) ())
+(defclass frame-trck (frame-text-info) ()) ; XXX should change string of eg "1/10" to be (values 1 10)?
+(defclass frame-trda (frame-text-info) ())
+(defclass frame-trsn (frame-text-info) ())
+(defclass frame-trso (frame-text-info) ())
+(defclass frame-tsoa (frame-text-info) ())
+(defclass frame-tsop (frame-text-info) ())
+(defclass frame-tsot (frame-text-info) ())
+(defclass frame-tsst (frame-text-info) ())
+(defclass frame-tsse (frame-text-info) ())
+(defclass frame-tsrc (frame-text-info) ())
+(defclass frame-tsiz (frame-text-info) ())
+(defclass frame-tyer (frame-text-info) ())
+
+(defclass frame-wcom (frame-url-link) ())
+(defclass frame-wcop (frame-url-link) ())
+(defclass frame-woaf (frame-url-link) ())
+(defclass frame-woar (frame-url-link) ())
+(defclass frame-woas (frame-url-link) ())
+(defclass frame-wors (frame-url-link) ())
+(defclass frame-wpay (frame-url-link) ())
+(defclass frame-wpub (frame-url-link) ())
+(defclass frame-wxxx (frame-url-link) ())
+
+;;
+;; many id3 tags are name/value pairs, with the name/value encoded in various ways
+;; this routine assumes that the name is always a string with a "normal" encoding (i.e. 0, 1, 2, or 3).
+;; a value, however, accepts any negative number, which means read
+;; the bytes an raw octets.
+(defun get-name-value-pair (instream len name-encoding value-encoding)
+  (log5:with-context  "get-name-value-pair"
+	(log-mp3-frame "reading from ~:d, len ~:d, name-encoding = ~d, value-encoding = ~d" (stream-seek instream 0 :current) len name-encoding value-encoding)
+	(let* ((old-pos (stream-seek instream 0 :current))
+		   (name (stream-read-string instream :encoding name-encoding))
+		   (name-len (- (stream-seek instream 0 :current) old-pos))
+		   (value))
+
+	  (log-mp3-frame "name = <~a>, name-len = ~d" name name-len)
+	  (setf value (if (>= value-encoding 0)
+					  (stream-read-string-with-len instream (- len name-len) :encoding value-encoding)
+					  (stream-read-sequence instream (- len name-len)))) ; if < 0, then just read as octets
+
+	  (values name value))))
+
+;;
+;; test to see if a string is a potentially valid frame id
+(defun possibly-valid-frame-id? (frame-id)
+  (labels ((numeric-char-p (c)
+			 (let ((code (char-code c)))
+			   (and (>= code (char-code #\0))
+					(<= code (char-code #\9))))))
+
+	(dotimes (i (length frame-id))
+	  (let ((c (aref frame-id i)))
+		(when (not (or (numeric-char-p c)
+					   (and (alpha-char-p c) (upper-case-p c))))
+		  (return-from possibly-valid-frame-id? nil))))
+	t))
+
+;;; Search by frame-id for a class, returning a class that can be used as arg to
+;;; make-instance.
+(defun find-frame-class (id)
+  (log5:with-context "find-frame-class"
+	(log-mp3-frame "looking for class <~a>" id)
+	(let ((found-class-symbol (find-symbol (string-upcase (concatenate 'string "frame-" id)) :MP3-FRAME))
+		  found-class)
+	  (when found-class-symbol
+		(setf found-class (find-class found-class-symbol))
+		(log-mp3-frame "found class: ~a" found-class)
+		(return-from find-frame-class found-class))
+
+	  (log-mp3-frame "didn't find class, checking general cases")
+
+	  ;; if not a "normal" frame-id, look at general cases of
+	  ;; starting with a 'T' or a 'W'
+	  (setf found-class (case (aref id 0)
+						  (#\T (log-mp3-frame "assuming text-info") (find-class (find-symbol "FRAME-TEXT-INFO" :MP3-FRAME)))
+						  (#\W (log-mp3-frame "assuming url-link")  (find-class (find-symbol "FRAME-URL-LINK"  :MP3-FRAME)))
+						  (t
+						   ;; we don't recognize the frame name.  if it could possibly be a real frame name,
+						   ;; then just read it raw
+						   (when (possibly-valid-frame-id? id)
+							 (log-mp3-frame "just reading raw")
+							 (find-class (find-symbol "RAW-FRAME" :MP3-FRAME))))))
+
+	  (log-mp3-frame "general case for id <~a> is ~a" id found-class)
+	  found-class)))
+
+(defun make-frame (version instream)
+  "Create an appropriate mp3 frame by reading data from INSTREAM."
+  (log5:with-context "find-mp3-frames"
+	(let* ((pos (stream-seek instream 0 :current))
+		   (byte (stream-read-u8 instream))
+		   frame-name frame-len frame-flags frame-class)
+
+	  (log-mp3-frame "reading from position ~:d (size of stream = ~:d" pos (stream-size instream))
+
+	  (when (zerop byte)
+		(log-mp3-frame "hit padding")
+		(return-from make-frame nil))	; hit padding
+
+	  (setf frame-name
+			(concatenate 'string (string (code-char byte)) (stream-read-string-with-len instream (ecase version (2 2) (3 3) (4 3)))))
+	  (setf frame-len (ecase version
+						(2 (stream-read-u24 instream))
+						(3 (stream-read-u32 instream))
+						(4 (stream-read-u32 instream :bits-per-byte 7))))
+
+	  (when (or (= version 3) (= version 4))
+		(setf frame-flags (stream-read-u16 instream)))
+
+	  (log-mp3-frame "making frame: id:~a, version: ~d, len: ~:d, flags: ~x" frame-name version frame-len frame-flags)
+	  (setf frame-class (find-frame-class frame-name))
+	  (when (or (> (+ (stream-seek instream 0 :current) frame-len) (stream-size instream))
+				(null frame-class))
+		(error 'mp3-frame-condition :message "bad frame found" :object frame-name :location pos))
+	  (make-instance frame-class :pos pos :version version :id frame-name :len frame-len :flags frame-flags :instream instream))))
 
 (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"
-  (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))
-
-	(setf (mp3-header mp3-file) (make-instance 'mp3-id3-header :instream mp3-file))
-	(ccl:with-input-from-vector (v (stream-read-octets mp3-file (size (mp3-header mp3-file))
-													   :bits-per-byte (if (header-unsynchronized-p (flags (mp3-header mp3-file))) 7 8)))
-
-	  (block read-loop
-		(loop
-	  		(let ((this-frame (make-frame v)))
-			  (when (null this-frame)
-				(return-from read-loop nil))
-			  (push this-frame (frames (mp3-header mp3-file)))))))))
+  (labels ((read-loop (version stream)
+			 (log-mp3-frame "Starting loop through ~:d bytes" (stream-size stream))
+			 (let (frames this-frame)
+			   (do ()
+				   ((>= (stream-seek stream 0 :current) (stream-size stream)))
+				 (handler-case
+					 (progn
+					   (setf this-frame (make-frame version stream))
+					   (when (null this-frame)
+						 (log-mp3-frame "hit padding: returning ~d frames" (length frames))
+						 (return-from read-loop (values t (nreverse frames))))
+					   (log-mp3-frame "bottom of read-loop: pos = ~:d, size = ~:d" (stream-seek stream 0 :current) (stream-size stream))
+					   (push this-frame frames))
+				   (condition (c)
+					 (log-mp3-frame "got condition ~a when making frame" c)
+					 (return-from read-loop (values nil (nreverse frames))))))
+
+			   (log-mp3-frame "hit end: returning ~d frames" (length frames))
+			   (values t (nreverse frames)))))
+
+	(log5:with-context "find-mp3-frames"
+	  (when (not (is-valid-mp3-file mp3-file))
+		(log-mp3-frame "~a is not an mp3 file" mp3-file)
+		(error 'mp3-frame-condition :location "find-mp3-frames" :object mp3-file :message "is not an mp3 file"))
+
+	  (log-mp3-frame "~a is a valid mp3 file" (stream-filename mp3-file))
+
+	  (setf (mp3-header mp3-file) (make-instance 'mp3-id3-header :instream mp3-file))
+	  (with-slots (size ext-header frames flags version) (mp3-header mp3-file)
+		(when (not (zerop size))
+		  (let ((mem-stream (make-mem-stream (stream-read-sequence mp3-file size
+																   :bits-per-byte (if (header-unsynchronized-p flags) 7 8)))))
+
+			;; must make extended header here since it is subject to unsynchronization.
+			(when (header-extended-p flags)
+			  (setf ext-header (make-instance 'mp3-extended-header :instream mem-stream)))
+			(multiple-value-bind (_ok _frames) (read-loop version mem-stream)
+			  (if (not _ok)
+				  (warn "had an error finding mp3 frames. potentially missed frames!"))
+			  (log-mp3-frame "ok = ~a, returing ~d frames" _ok (length _frames))
+			  (setf frames _frames)
+			  _ok)))))))
+
+(defun get-frame-info (mp3-file frame-id)
+  (with-slots (frames version) (mp3-header mp3-file)
+	(dolist (f frames)
+	  (if (string= frame-id (id f))
+		  (return-from get-frame-info f)))))

mp3-tag.lisp

@@ -2,5 +2,81 @@
 ;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
 (in-package #:mp3-tag)
 
-(defmethod show-tags ((me mp3-stream))
-  (format t "~a:~a~%" (filename me) (mp3-frame:vpprint (audio-streams:mp3-header me) nil)))
+
+(defmethod album ((me mp3-file-stream))
+  (let ((ret)
+		(f (get-frame-info me (ecase (version (mp3-header me)) (2 "TAL") (3 "TALB") (4 "TALB")))))
+	(if (not f)
+		(if (v21-tag-header (mp3-header me))
+			(setf ret (album (v21-tag-header (mp3-header me)))))
+		(setf ret (info f)))
+	ret))
+
+(defmethod artist ((me mp3-file-stream))
+  (let ((f (get-frame-info me (ecase (version (mp3-header me)) (2 "TP1") (3 "TPE1") (4 "TPE1")))))
+	(if f
+		(info f)
+		nil)))
+
+(defmethod album-artist ((me mp3-file-stream)) nil)
+(defmethod comment ((me mp3-file-stream)) nil)
+(defmethod composer ((me mp3-file-stream)) nil)
+(defmethod copyright ((me mp3-file-stream)) nil)
+(defmethod year ((me mp3-file-stream)) nil)
+(defmethod encoder ((me mp3-file-stream)) nil)
+(defmethod groups ((me mp3-file-stream)) nil)
+(defmethod lyrics ((me mp3-file-stream)) nil)
+(defmethod purchased-date ((me mp3-file-stream)) nil)
+(defmethod title ((me mp3-file-stream)) nil)
+(defmethod tool ((me mp3-file-stream)) nil)
+(defmethod writer ((me mp3-file-stream)) nil)
+
+(defmethod compilation ((me mp3-file-stream)) nil)
+(defmethod disk  ((me mp3-file-stream)) nil)
+(defmethod tempo ((me mp3-file-stream)) nil)
+(defmethod genre ((me mp3-file-stream)) nil)
+(defmethod track ((me mp3-file-stream)) nil)
+
+(defmethod show-tags ((me mp3-file-stream) &key (raw nil))
+  "Show the tags for an mp3-file"
+  (if raw
+	  (format t "~a:~a~%" (stream-filename me) (mp3-frame:vpprint (audio-streams:mp3-header me) nil))
+	  (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)))
+		(format t "~a~%" (stream-filename 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)))))

mp4-atom.lisp

@@ -123,7 +123,7 @@
 	(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)
-				 (stream-read-string mp4-file :size (- (atom-size atom) 16))) methods))
+				 (stream-read-string-with-len mp4-file (- (atom-size atom) 16))) methods))
 	  `(progn ,@methods)))
   )
 
@@ -175,7 +175,7 @@
 
 (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) (stream-read-octets mp4-file (- (atom-size atom) 16)))
+	(setf (slot-value blob 'blob) (stream-read-sequence mp4-file (- (atom-size atom) 16)))
 	blob))
 
 
@@ -268,7 +268,7 @@ seek forward past end of this atom."
 		   (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))
+		(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 (stream-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*)
@@ -296,7 +296,7 @@ seek forward past end of this atom."
 	  ;; 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"
+							  (format s "Atom <~a> @ ~:d of size ~:d and child count of ~d"
 									  (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
@@ -362,21 +362,19 @@ seek forward past end of this atom."
 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" ))
+	  (error 'mp4-atom-condition :location "find-mp4-atoms" :object 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" (stream-seek mp4-file 0 :current) (stream-size mp4-file))
 
-	  (log-mp4-atom "before read-file loop, file-position = ~:d, end = ~:d" (stream-seek mp4-file 0 :current) (file-size mp4-file))
+	(setf (mp4-atoms mp4-file) (make-mp4-atom-collection))
+	(do ((new-atom))
+		((> (+ 8 (stream-seek mp4-file 0 :current)) (stream-size mp4-file)))
+	  (log-mp4-atom "top of read-file loop, current file-position = ~:d, end = ~:d" (stream-seek mp4-file 0 :current) (stream-size mp4-file))
+	  (setf new-atom (make-mp4-atom mp4-file))
+	  (when new-atom (add (mp4-atoms mp4-file) new-atom)))
+
+	(log-mp4-atom "returning atom-collection of size ~d" (size (mp4-atoms mp4-file)))))
 
-	  (block stream-read-file
-		(do ()
-			((> (+ 8 (stream-seek mp4-file 0 :current)) (file-size mp4-file)))
-		  (log-mp4-atom "top of read-file loop, current file-position = ~:d, end = ~:d" (stream-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"
@@ -435,3 +433,7 @@ call traverse atom (unless length of path == 1, in which case, we've found out m
 	(if atom
 		(atom-value atom)
 		nil)))
+
+(defun mp4-show-raw-tag-atoms (mp4-file-stream)
+  (map-mp4-atom (mp4-atom::traverse  (mp4-atoms mp4-file-stream) (list +mp4-atom-moov+ +mp4-atom-udta+ +mp4-atom-meta+ +mp4-atom-ilst+)))))
+

mp4-tag.lisp

@@ -2,25 +2,25 @@
 ;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
 (in-package #:mp4-tag)
 
-(defmethod album ((me mp4-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-album+))
-(defmethod album-artist ((me mp4-stream))   (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-album-artist+))
-(defmethod artist ((me mp4-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-artist+))
-(defmethod comment ((me mp4-stream))        (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-comment+))
-(defmethod composer ((me mp4-stream))       (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-composer+))
-(defmethod copyright ((me mp4-stream))      (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-copyright+))
-(defmethod year ((me mp4-stream))           (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-year+))
-(defmethod encoder ((me mp4-stream))        (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-encoder+))
-(defmethod groups ((me mp4-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-groups+))
-(defmethod lyrics ((me mp4-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-lyrics+))
-(defmethod purchased-date ((me mp4-stream)) (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-purchased-date+))
-(defmethod title ((me mp4-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-title+))
-(defmethod tool ((me mp4-stream))           (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-tool+))
-(defmethod writer ((me mp4-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-writer+))
+(defmethod album ((me mp4-file-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-album+))
+(defmethod album-artist ((me mp4-file-stream))   (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-album-artist+))
+(defmethod artist ((me mp4-file-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-artist+))
+(defmethod comment ((me mp4-file-stream))        (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-comment+))
+(defmethod composer ((me mp4-file-stream))       (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-composer+))
+(defmethod copyright ((me mp4-file-stream))      (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-copyright+))
+(defmethod year ((me mp4-file-stream))           (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-year+))
+(defmethod encoder ((me mp4-file-stream))        (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-encoder+))
+(defmethod groups ((me mp4-file-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-groups+))
+(defmethod lyrics ((me mp4-file-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-lyrics+))
+(defmethod purchased-date ((me mp4-file-stream)) (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-purchased-date+))
+(defmethod title ((me mp4-file-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-title+))
+(defmethod tool ((me mp4-file-stream))           (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-tool+))
+(defmethod writer ((me mp4-file-stream))         (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-writer+))
 
-(defmethod compilation ((me mp4-stream))    (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-compilation+))
-(defmethod disk  ((me mp4-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-disk+))
-(defmethod tempo ((me mp4-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-tempo+))
-(defmethod genre ((me mp4-stream))
+(defmethod compilation ((me mp4-file-stream))    (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-compilation+))
+(defmethod disk  ((me mp4-file-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-disk+))
+(defmethod tempo ((me mp4-file-stream))          (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-tempo+))
+(defmethod genre ((me mp4-file-stream))
   (let ((genre   (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-genre+))
 		(genre-x (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-genre-x+)))
 	(assert (not (and genre genre-x)))
@@ -29,7 +29,7 @@
 	  (genre-x (tag:get-genre-text genre-x))
 	  (t nil))))
 
-(defmethod track ((me mp4-stream))
+(defmethod track ((me mp4-file-stream))
   (let ((track   (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-track+))
 		(track-n (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-track-n+)))
 	(assert (not (and track track-n)))
@@ -37,44 +37,46 @@
 		track
 		track-n)))
 
-(defmethod show-tags ((me mp4-stream))
-  "Show the understood tags for MP4-FILE"
-  (format t "~a~%" (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))))
+(defmethod show-tags ((me mp4-file-stream) &key (raw nil))
+  "Show the tags for an MP4-FILE"
+  (if raw
+	  (mp4-atom:mp4-show-raw-tag-atoms 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)))
+		(format t "~a~%" (stream-filename 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

@@ -4,20 +4,26 @@
 
 (defpackage #:audio-streams
   (:export #:octets #:make-octets
-		   #:base-file-stream
-		   #:filename #:instream #:file-size #:endian
+		   #:mp3-file-stream #:mp4-file-stream #:base-mem-stream
+		   #:parse-mp3-file #:parse-mp4-file #:mp3-frame-condition
+		   #:make-mem-stream #:stream-filename
+		   #:mp4-atoms #:mp3-header
 		   #:stream-read-u8 #:stream-read-u16 #:stream-read-u24 #:stream-read-u32
-		   #:stream-read-string #:stream-read-octets
-		   #:stream-seek #:stream-close
-		   #:mp4-stream #:make-mp4-stream #:mp4-atoms
-		   #:mp3-stream #:make-mp3-stream #:mp3-header
-		   #:stream-read-sync-safe-u32)
+		   #:stream-decode-iso-string #:stream-deocode-ucs-string #:stream-decode-ucs-be-string
+		   #:stream-decode-utf-8-string #:stream-decode-string #:stream-read-iso-string-with-len
+		   #:stream-read-ucs-string-with-len #:stream-read-ucs-be-string-with-len
+		   #:stream-read-utf-8-string-with-len #:stream-read-string-with-len
+		   #:stream-read-iso-string #:stream-read-ucs-string #:stream-read-ucs-be-string
+		   #:stream-read-utf-8-string #:stream-read-string #:trim-string
+		   #:stream-read-string #:stream-read-sequence #:stream-size
+		   #:stream-seek #:stream-close)
   (: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
+		   #:atom-type #:vpprint #:*tag-path* #:tag-get-value #:mp4-atom-condition
+		   #:mp4-show-raw-tag-atoms
 		   #:+itunes-album+
 		   #:+itunes-album-artist+
 		   #:+itunes-artist+
@@ -43,12 +49,13 @@
   (:use #:common-lisp #:audio-streams))
 
 (defpackage :mp3-frame
-  (:export :mp3-frame #:find-mp3-frames #:mp3-frame-condition #:vpprint #:header)
+  (:export :mp3-frame #:find-mp3-frames #:mp3-frame-condition #:vpprint #:header :get-frame-info
+		   :v21-tag-header :info :version)
   (:use :common-lisp :audio-streams))
 
 (defpackage :mp3-tag
   (:export :show-tags)
-  (:use :common-lisp :audio-streams))
+  (:use :common-lisp :audio-streams :mp3-frame))
 
 (defpackage #:tag
   (:export #:get-genre-text)

streams.lisp

@@ -9,179 +9,294 @@
 (deftype octet () '(unsigned-byte 8))
 (defmacro make-octets (len) `(make-array ,len :element-type 'octet))
 
-(defclass base-file-stream ()
-  ((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-stream) &key read-only &allow-other-keys)
-  (log5:with-context "base-file-stream-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 file-size (file-length instream))
-	(log-stream "base-file-stream-initializer built stream = ~a, name = ~a, size = ~:d, endian = ~a"
-				instream filename file-size endian))))
-
-(defmethod stream-close ((me base-file-stream))
-  "Close an open stream."
-  (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 stream-seek ((me base-file-stream) offset from)
-  "C-library like seek function. from can be one of :current, :start, :end.
-Returns the current offset into the stream"
-  (with-slots (instream file-size) me
+(defclass base-stream ()
+  ((stream :accessor stream)))
+
+(defclass base-file-stream (base-stream)
+  ((stream-filename :accessor stream-filename)))
+
+(defclass mp3-file-stream (base-file-stream)
+  ((mp3-header  :accessor mp3-header)))
+
+(defclass mp4-file-stream (base-file-stream)
+  ((mp4-atoms :accessor mp4-atoms :initform nil)))
+
+(defun make-file-stream (class-name filename &key (read-only t))
+  (let ((new-stream (make-instance (find-class class-name))))
+	(setf (stream new-stream) (if read-only
+								  (open filename :direction :input :element-type 'octet)
+								  (open filename :direction :io :if-exists :overwrite :element-type 'octet)))
+	(setf (stream-filename new-stream) filename)
+	new-stream))
+
+(defclass base-mem-stream (base-stream) ())
+
+(defun make-mem-stream (vector)
+  (let ((new-stream (make-instance 'base-mem-stream)))
+	(setf (stream new-stream) (ccl:make-vector-input-stream vector))
+	new-stream))
+
+
+(defmethod stream-close ((in-stream base-file-stream))
+  (with-slots (stream) in-stream
+	(when stream
+	  (close stream)
+	  (setf stream nil))))
+
+(defmethod stream-close ((in-stream base-mem-stream))
+  (with-slots (stream) in-stream
+	(setf stream nil)))
+
+(defmethod stream-size ((in-stream base-stream))
+  (ccl::stream-length (stream in-stream)))
+
+(defmethod stream-seek ((in-stream base-stream) offset from)
+  (with-slots (stream) in-stream
 	(ecase from
-	  (:start (file-position instream offset))
-	  (:current (file-position instream (+ (file-position instream) offset)))
-	  (:end (file-position instream (- file-size offset))))))
-
-;;
-;; Based on a function from Practical Common Lisp by Peter Seibel.
-(defun read-octets (instream bytes &key (bits-per-byte 8) (endian :little-endian))
-  (ecase endian
-	(:big-endian
-	 (loop with value = 0
-		   for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do
-			 (setf (ldb (byte bits-per-byte low-bit) value) (read-byte instream))
-		   finally (return value)))
-	(:little-endian
-	 (loop with value = 0
-		   for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
-			 (setf (ldb (byte bits-per-byte low-bit) value) (read-byte instream))
-		   finally (return value)))))
-
-(defmethod stream-read-u8 ((me base-file-stream))
+	  (:start (ccl::stream-position stream offset))
+	  (:current (if (zerop offset)
+					(ccl::stream-position stream)
+					(ccl::stream-position stream (+ (ccl::stream-position stream) offset))))
+	  (:end (ccl::stream-position stream (- (ccl::stream-length stream) offset))))))
+
+(defun stream-read-octets (instream bytes &key (bits-per-byte 8))
+  (loop with value = 0
+		for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do
+		  (setf (ldb (byte bits-per-byte low-bit) value) (read-byte instream))
+		finally (return value)))
+
+(defmethod stream-read-u8 ((in-stream base-stream) &key (bits-per-byte 8))
   "read 1 byte from file"
-  (with-slots (endian instream) me
-	(read-octets instream 1 :endian endian)))
+  (with-slots (stream) in-stream
+	(stream-read-octets stream 1 :bits-per-byte bits-per-byte)))
 
-(defmethod stream-read-u16 ((me base-file-stream))
+(defmethod stream-read-u16 ((in-stream base-stream) &key (bits-per-byte 8))
   "read 2 bytes from file"
-  (with-slots (endian instream) me
-	(read-octets instream 2 :endian endian)))
+  (with-slots (stream) in-stream
+	(stream-read-octets stream 2 :bits-per-byte bits-per-byte)))
 
-(defmethod stream-read-u24 ((me base-file-stream))
+(defmethod stream-read-u24 ((in-stream base-stream) &key (bits-per-byte 8))
   "read 3 bytes from file"
-  (with-slots (endian instream) me
-	(read-octets instream 3 :endian endian)))
+  (with-slots (stream) in-stream
+	(stream-read-octets stream 3 :bits-per-byte bits-per-byte)))
 
-(defmethod stream-read-u32 ((me base-file-stream))
+(defmethod stream-read-u32 ((in-stream base-stream) &key (bits-per-byte 8))
   "read 4 bytes from file"
-  (with-slots (endian instream) me
-	(read-octets instream 4 :endian endian)))
-
-(defmethod stream-read-string ((me base-file-stream) &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)"
-  (with-output-to-string (s)
-	(with-slots (instream) me
-	  (let ((terminated nil)
-			(count 0)
-			(byte))
-		(loop
-		  (when (if size (= count size) terminated) (return))
-		  (setf byte (read-byte instream))
-		  (incf count)
-		  ;;;(log-stream "count = ~d, terminators = ~a, byte-read was ~c" count terminators (code-char byte))
-		  (when (member byte terminators :test #'=)
-			(setf terminated t))
-		  (when (not terminated)
-			(write-char (code-char byte) s)))))))
-
-(defmethod stream-read-octets ((me base-file-stream) size &key (bits-per-byte 8))
-  "Read SIZE octets from input-file.  If bits-per-byte"
+  (with-slots (stream) in-stream
+	(stream-read-octets stream 4 :bits-per-byte bits-per-byte)))
+
+;; (defmethod stream-read-string ((stream base-stream) &key size (terminators nil))
+;;   "Read normal string from stream. 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)"
+;;   (with-output-to-string (s)
+;; 	(with-slots (stream) stream
+;; 	  (let ((terminated nil)
+;; 			(count 0)
+;; 			(byte))
+;; 		(loop
+;; 		  (when (if size (= count size) terminated) (return))
+;; 		  (setf byte (read-byte stream))
+;; 		  (incf count)
+;; 		  (when (member byte terminators :test #'=)
+;; 			(setf terminated t))
+;; 		  (when (not terminated)
+;; 			(write-char (code-char byte) s)))))))
+
+(defmethod stream-read-sequence ((stream base-stream) size &key (bits-per-byte 8))
+  "Read SIZE octets from input-file in BIT-PER-BYTE sizes"
   (ecase bits-per-byte
 	(8
 	 (let ((octets (make-octets size)))
-	   (read-sequence octets (slot-value me 'instream))))
+	   (read-sequence octets (slot-value stream 'stream))
+	   octets))
 	(7
 	 (let* ((last-byte-was-FF nil)
 			(byte nil)
 			(octets (ccl:with-output-to-vector (out)
 					  (dotimes (i size)
-						(setf byte (stream-read-u8 me))
+						(setf byte (stream-read-u8 stream))
 						(if last-byte-was-FF
 							(if (not (zerop byte))
 								(write-byte byte out))
 							(write-byte byte out))
 						(setf last-byte-was-FF (= byte #xFF))))))
+	   (format t "file pos is now: ~:d~%" (stream-seek stream 0 :current))
+	   (format t "length of data is ~:d~%" (length octets))
 	   octets))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; STRINGS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MP4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; get rid of trailing nulls and blanks
+(defmacro trim-string (s) `(string-trim '(#\Null #\Space) ,s))
 
-(defclass mp4-stream (base-file-stream)
-  ((mp4-atoms :accessor mp4-atoms :initform nil))
-  (:documentation "Class to access m4a/mp4 files"))
+;;
+;; decode octets as an iso-8859-1 string (encoding == 0)
+(defun stream-decode-iso-string (octets &key (start 0) (end nil))
+  (ccl:decode-string-from-octets octets :start start :end end :external-format :iso-8859-1))
 
-(defun make-mp4-stream (filename read-only &key)
-  "Convenience function to create an instance of MP4-FILE with appropriate init args"
-  (log5:with-context "make-mp4-stream"
-	(log-stream "make-mp4-stream is opening ~a" filename)
-	(let (handle)
-	  (handler-case 
-		  (progn
-			(setf handle (make-instance 'mp4-stream :filename filename :endian :little-endian :read-only read-only))
-			(with-slots (mp4-atoms) handle
-			  (log-stream "getting atoms")
-			  (setf mp4-atoms (mp4-atom:find-mp4-atoms handle))))
-		(condition (c)
-		  (warn "make-mp4-stream got condition: ~a" c)
-		  (when handle (stream-close handle))
-		  (setf handle nil)))
-		handle)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MP3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defclass mp3-stream (base-file-stream)
-  ((mp3-header :accessor mp3-header :initform nil))
-  (:documentation "Class to access mp3 files"))
-
-(defun make-mp3-stream (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-stream"
-	(log-stream "opening ~a, read-only = ~a" filename read-only)
-	(let (handle)
+;;
+;; decode octets as a ucs string (encoding == 1)
+;; XXX: Coded this way because I can't seem to get a simple :external-format :ucs-2 to work correctly 
+;; AND some taggers encode a UCS-2 empty string w/o a byte-order mark (i.e. null strings are
+;; sometimes encoded as #(00 00))
+(defun stream-decode-ucs-string (octets &key (start 0) (end nil))
+	(labels ((get-byte-order-mark (octets)
+			   (let ((retval 0))
+				 (setf (ldb (byte 8 0) retval) (aref octets 1))
+				 (setf (ldb (byte 8 8) retval) (aref octets 0))
+				 (assert (or (= #xfffe retval) (= #xfeff retval)) () "decode-ucs: invalid byte order mark ~x" retval)
+				 retval)))
+
+	  ;; special case: empty (and mis-coded) string
+	  (cond ((zerop (length octets))
+			 (make-string 0))
+			(t
+			 ;;
+			 ;; else, we have a (hopefully) properly encoded string
+			 (let ((bom (get-byte-order-mark octets)))
+			   (ecase (the fixnum bom)
+				 (#xfffe (ccl:decode-string-from-octets octets :start (+ 2 start) :end end :external-format :ucs-2le))
+				 (#xfeff (ccl:decode-string-from-octets octets :start (+ 2 start) :end end :external-format :ucs-2be))
+				 (0      (make-string 0))))))))
+
+;;
+;; decode octets as a ucs-be string (encoding == 2)
+(defun stream-decode-ucs-be-string (octets &key (start 0) (end nil))
+  (ccl:decode-string-from-octets octets :start start :end end :external-format :ucs-2be))
+
+;;
+;; decode octets as a utf-8 string
+(defun stream-decode-utf-8-string (octets &key (start 0) (end nil))
+  (ccl:decode-string-from-octets octets :start start :end end :external-format :utf-8))
+
+;;
+;; decode octets depending on encoding
+(defun stream-decode-string (octets &key (start 0) (end nil) (encoding 0))
+  (ecase encoding
+	(0 (stream-decode-iso-string octets :start start :end end))
+	(1 (stream-decode-ucs-string octets :start start :end end))
+	(2 (stream-decode-ucs-be-string octets :start start :end end))
+	(3 (stream-decode-utf-8-string octets :start start :end end))))
+
+;;
+;; read an iso-8859-1 string of length 'len' (encoding = 0)
+(defmethod stream-read-iso-string-with-len ((instream base-stream) len)
+  (let ((octets (stream-read-sequence instream len)))
+	(stream-decode-iso-string octets)))
+
+;;
+;; read an ucs-2 string of length 'len' (encoding = 1)
+(defmethod stream-read-ucs-string-with-len ((instream base-stream) len)
+  (let ((octets (stream-read-sequence instream len)))
+	  (stream-decode-ucs-string octets)))
+
+;;
+;; read an ucs-2-be string of length 'len' (encoding = 2)
+(defmethod stream-read-ucs-be-string-with-len ((instream base-stream) len)
+  (let ((octets (stream-read-sequence instream len)))
+	(stream-decode-ucs-be-string octets)))
+
+;;
+;; read an utf-8 string of length 'len' (encoding = 3)
+(defmethod stream-read-utf-8-string-with-len ((instream base-stream) len)
+  (let ((octets (stream-read-sequence instream len)))
+	(stream-decode-utf-8-string octets)))
+
+;;
+;; Read in a string of a given encoding of length 'len'
+(defmethod stream-read-string-with-len ((instream base-stream) len &key (encoding 0))
+  ;(format t "s-wth-len: ~a, ~d, ~d~%" instream len encoding)
+  (ecase encoding
+	(0 (stream-read-iso-string-with-len instream len))
+	(1 (stream-read-ucs-string-with-len instream len))
+	(2 (stream-read-ucs-be-string-with-len instream len))
+	(3 (stream-read-utf-8-string-with-len instream len))))
+
+;;
+;; Read in a null terminated iso-8859-1 string
+(defmethod stream-read-iso-string ((instream base-stream))
+  (let ((octets (ccl:with-output-to-vector (out)
+				  (do ((b (stream-read-u8 instream) (stream-read-u8 instream)))
+					  (nil)
+					(when (zerop b)
+					  (return))			; leave loop w/o writing
+					(write-byte b out)))))
+	(stream-decode-iso-string octets)))
+
+;;
+;; Read in a null terminated ucs string 
+(defmethod stream-read-ucs-string ((instream base-stream))
+  (let ((octets (ccl:with-output-to-vector (out)
+				  (do* ((b0 (stream-read-u8 instream)
+							(stream-read-u8 instream))
+						(b1 (stream-read-u8 instream)
+							(stream-read-u8 instream)))
+					   (nil)
+					(when (and (zerop b0) (zerop b1))
+					  (return))
+					(write-byte b0 out)
+					(write-byte b1 out)))))
+	(stream-decode-ucs-string octets)))
+
+;;
+;; Read in a null terminated ucs-be string
+(defmethod stream-read-ucs-be-string ((instream base-stream))
+  (let ((octets (ccl:with-output-to-vector (out)
+				  (do* ((b0 (stream-read-u8 instream)
+							(stream-read-u8 instream))
+						(b1 (stream-read-u8 instream)
+							(stream-read-u8 instream)))
+					   (nil)
+					(when (and (zerop b0) (zerop b1))
+					  (return))
+					(write-byte b0 out)
+					(write-byte b1 out)))))
+	(stream-decode-ucs-be-string octets)))
+
+;;
+;; Read in a null terminated utf-8 string (encoding == 3)
+(defmethod stream-read-utf-8-string ((instream base-stream))
+  (let ((octets (ccl:with-output-to-vector (out)
+				  (do ((b (stream-read-u8 instream)
+						  (stream-read-u8 instream)))
+					  (nil)
+					(when (zerop b)
+					  (return))
+					(write-byte b out)))))
+	(stream-decode-utf-8-string octets)))
+
+;;
+;; Read in a null terminated string of a given encoding
+(defmethod stream-read-string ((instream base-stream) &key (encoding 0))
+  (ecase encoding
+	(0 (stream-read-iso-string instream))
+	(1 (stream-read-ucs-string instream))
+	(2 (stream-read-ucs-be-string instream))
+	(3 (stream-read-utf-8-string instream))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; FILES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun parse-mp4-file (filename)
+  (let (stream)
+	(handler-case
+		(progn
+		  (setf stream (make-file-stream 'mp4-file-stream filename))
+		  (mp4-atom:find-mp4-atoms stream))
+	  (mp4-atom:mp4-atom-condition (c)
+		(warn "make-mp4-stream got condition: ~a" c)
+		(when stream (stream-close stream))
+		(setf stream nil)))
+	stream))
+
+(defun parse-mp3-file (filename)
+  (let (stream)
 	  (handler-case
 		  (progn
-			(setf handle (make-instance 'mp3-stream :filename filename :endian :big-endian :read-only read-only))
-			(with-slots (mp3-header) handle
-			  (log-stream "getting frames")
-			  (setf mp3-header (mp3-frame:find-mp3-frames handle))))
-		(condition (c)
+			(setf stream (make-file-stream 'mp3-file-stream filename))
+			(mp3-frame:find-mp3-frames stream))
+		(mp3-frame:mp3-frame-condition (c)
 		  (warn "make-mp3-stream got condition: ~a" c)
-		  (when handle (stream-close handle))
-		  (setf handle nil)))
-	  handle)))
-
-(defmethod stream-read-sync-safe-u32 ((me mp3-stream))
-  "Read a sync-safe integer from file.  Used by mp3 files"
-  (read-octets (slot-value me 'instream) 4 :bits-per-byte 7 :endian :little-endian))
-
-
-#|
-(defun tst ()
-  (let ((foo (ccl:with-output-to-vector (f) 
-			   (write-byte #xDE f)
-			   (write-byte #xAD f)
-			   (write-byte #xBE f)
-			   (write-byte #xEF f))))
-	(ccl:with-input-from-vector (f foo)
-	  (format t "Length is ~d~%" (ccl::stream-length f))
-	  (dotimes (j 2)
-		(format t "Iteration ~d~%" j)
-		(ccl::stream-position f 0)
-		(dotimes (i (ccl::stream-length f))
-		  (format t "~d: ~x~%" i (read-byte f)))))))
-|#
+		  (when stream (stream-close stream))
+		  (setf stream nil)))
+	stream))

taglib-tests.lisp

@@ -34,7 +34,7 @@
 (defun mp4-test0 (file)
   (let (foo)
 	(unwind-protect 
-		 (setf foo (make-mp4-stream file t))
+		 (setf foo (parse-mp4-file file))
 	  (when foo (stream-close foo)))
 	foo))
 
@@ -51,7 +51,7 @@
 (defun mp3-test0 (file)
   (let (foo)
 	(unwind-protect 
-		 (setf foo (make-mp3-stream file t))
+		 (setf foo (parse-mp3-file file))
 	  (when foo (stream-close foo)))
 	foo))
 
@@ -66,6 +66,7 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (defun test2 (&key (dir "Queen"))
+  (set-pathname-encoding-for-osx)
   (osicat:walk-directory dir (lambda (f)
 							   (if (has-extension f "mp3")
 								   (let ((file (mp3-test0 f)))