new tree structure for mp4-atoms complete

abstract-tag.lisp

@@ -300,7 +300,7 @@
 (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 cover        ((me mp4-file-stream)) (length (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-cover-art+)))
+;;;(defmethod cover        ((me mp4-file-stream)) (mp4-atom:tag-get-value (mp4-atoms me) mp4-atom:+itunes-cover-art+))
 (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+))
@@ -331,9 +331,9 @@
   (format t "~a~%" (stream-filename me))
   (if raw
       (progn
-        (mp4-atom:mp4-show-raw-tag-atoms me t)
         (if (audio-info me)
-          (mp4-atom:vpprint (audio-info me) t)))
+            (mp4-atom:vpprint (audio-info me) t))
+        (mp4-atom:mp4-show-raw-tag-atoms me t))
       (let ((album (album me))
             (album-artist (album-artist me))
             (artist (artist me))
@@ -341,7 +341,7 @@
             (compilation (compilation me))
             (composer (composer me))
             (copyright (copyright me))
-            (cover (cover me))
+;;;            (cover (cover me))
             (disk (disk me))
             (encoder (encoder me))
             (genre (genre me))
@@ -355,14 +355,15 @@
 
         (if (audio-info me)
           (mp4-atom:vpprint (audio-info me) t))
+
         (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: ~[no~;yes;unknown~]~%" (if compilation compilation 2))
+        (when compilation (format t "~4tcompilation: ~[no~;yes;unknown~]~%" (if compilation compilation 2)))
         (when composer (format t "~4tcomposer: ~a~%" composer))
         (when copyright (format t "~4tcopyright: ~a~%" copyright))
-        (when cover (format t "~4tcover: Size: :~d~%" cover))
+;;;        (when cover (format t "~4tcover: Number of covers: :~d~%" cover))
         (when disk (format t "~4tdisk: ~a~%" disk))
         (when encoder (format t "~4tencoder: ~a~%" encoder))
         (when genre (format t "~4tgenre: ~a~%" genre))

mp4-atom.lisp

@@ -92,7 +92,8 @@ string representation"
 
 (defconstant +m4-ftyp+               (mk-mp4-atom-type #\f #\t #\y #\p) "This should be the first atom type found in file")
 
-(defconstant +audioprop-hdlr+        (mk-mp4-atom-type #\h #\d #\l #\r) "Found under trak.mdia and tells what kind of handler it is")
+(defconstant +mp4-atom-hdlr+         (mk-mp4-atom-type #\h #\d #\l #\r) "Found under trak.mdia and tells what kind of handler it is")
+
 (defconstant +audioprop-mdhd+        (mk-mp4-atom-type #\m #\d #\h #\d) "Found under trak.mdia and holds data to calculate length of audio")
 (defconstant +audioprop-stsd+        (mk-mp4-atom-type #\s #\t #\s #\d) "Container atom: found under trak.mdia.minf.stbl and holds bit-rate, etc")
 (defconstant +audioprop-mp4a+        (mk-mp4-atom-type #\m #\p #\4 #\a) "Found under trak.mdia.minf.stbl")
@@ -156,7 +157,6 @@ to read the payload of an atom."
       (loop for end = (+ atom-file-pos atom-size)
             for current = (stream-here mp4-file) then (stream-here mp4-file)
             while (< current end) do
-              ;;(break "Now at ~a/~a" current end)
               (make-mp4-atom mp4-file me)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ILST ATOMS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -166,7 +166,6 @@ to read the payload of an atom."
   "Construct an ilst atom.  ILST atoms are containers that hold data elements related to tagging.
 Loop through this container and construct constituent atoms"
   (declare #.utils:*standard-optimize-settings*)
-  ;;(break "ilst")
   (log5:with-context "atom-ilst-initializer"
     (with-mp4-atom-slots (me)
       (log-mp4-atom "atom-ilst-init: found ilst atom <~a> @ ~:d, looping for ~:d bytes"
@@ -267,7 +266,6 @@ Loop through this container and construct constituent atoms"
           rflag    (stream-read-u32 mp4-file)
           rmask    (stream-read-u32 mp4-file)
           mhdlr    (stream-read-sequence mp4-file (- atom-size 32))) ; 32 is 8-bytes of header plus fields above
-    ;;(break "hdlr")
     ))
 
 (defclass atom-mdhd (mp4-atom)
@@ -412,7 +410,6 @@ reading the container atoms"
 
 (defmethod initialize-instance :around ((me atom-meta) &key mp4-file &allow-other-keys)
   (declare #.utils:*standard-optimize-settings*)
-  ;;(break "meta")
    (with-slots (version flags) me
      (setf version (stream-read-u8 mp4-file)
            flags   (stream-read-u24 mp4-file)))
@@ -515,38 +512,42 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
     (setf (mp4-atoms mp4-file) *tree*)))
 
 
-(defvar *ilst-data* (list +mp4-atom-moov+ +mp4-atom-udta+ +mp4-atom-meta+ +mp4-atom-ilst+ nil +itunes-ilst-data+))
+(defparameter *ilst-data* (list +root+ +mp4-atom-moov+ +mp4-atom-udta+
+                                +mp4-atom-meta+ +mp4-atom-ilst+ nil
+                                +itunes-ilst-data+)
+  "iTunes artist/album/etc path. The 5th element should be set to
+one of the +iTunes- constants")
 
-(defmethod tag-get-value (atoms node)
+(defmethod tag-get-value (atoms atom-type)
   "Helper function to extract text from ILST atom's data atom"
   (declare #.utils:*standard-optimize-settings*)
-  (aif (tree:find-tree atoms
-                       (lambda (x) (= (atom-type x) node)))
-       (atom-value it)
+  (setf (nth 5 *ilst-data*) atom-type)
+  (aif (tree:at-path atoms *ilst-data* (lambda (x y)
+                                         (= (mp4-atom:atom-type (tree:data x)) y)))
+       (atom-value (tree:data it))
        nil))
 
-;; (defun mp4-show-raw-tag-atoms (mp4-file-stream out-stream)
-;;   (declare #.utils:*standard-optimize-settings*)
-;;   (map-mp4-atom (traverse (mp4-atoms mp4-file-stream) +path-to-ilst+)
-;;                 :depth 0
-;;                 :func (lambda (atom depth)
-;;                         (when (= (atom-type atom) +itunes-ilst-data+)
-;;                           (format out-stream "~vt~a~%" depth (vpprint atom nil))))))
-
-;; ;;; define these as constants to limit consing when get-audio-properties-atoms is called
-;; (defconstant +audio-prop-mdia+ (list +mp4-atom-moov+ +mp4-atom-trak+ +mp4-atom-mdia+))
-;; (defconstant +audio-prop-mdhd+ (list +audioprop-mdhd+))
-;; (defconstant +audio-prop-mp4a+ (list +mp4-atom-minf+ +mp4-atom-stbl+ +audioprop-mp4a+))
-;; (defconstant +audio-prop-esds+ (list +audioprop-esds+))
+(defun mp4-show-raw-tag-atoms (mp4-file-stream out-stream)
+  "Show all the iTunes data atoms"
+  (declare #.utils:*standard-optimize-settings*)
+  (let ((top-node (tree:at-path (mp4-atoms mp4-file-stream)
+                                (list +root+ +mp4-atom-moov+ +mp4-atom-udta+ +mp4-atom-meta+ +mp4-atom-ilst+)
+                                (lambda (x y) (= (mp4-atom:atom-type (tree:data x)) y)))))
+    (loop for node = (tree:first-child top-node)
+            then (tree:next-sibling node) until (null node) do
+            (format out-stream "~2t~a~%" (vpprint (tree:data node) nil)))))
 
 (defun get-audio-properties-atoms (mp4-file)
   "Get the audio property atoms from MP4-FILE"
   (declare #.utils:*standard-optimize-settings*)
-  (let ((mdhd       (tree:find-tree (mp4-atoms mp4-file) (lambda (x) (= (atom-type x) +audioprop-mdhd+))))
-        (audioprop1 (tree:find-tree (mp4-atoms mp4-file) (lambda (x) (= (atom-type x) +audioprop-mp4a+))))
-        (audioprop2 (tree:find-tree (mp4-atoms mp4-file) (lambda (x) (= (atom-type x) +audioprop-esds+)))))
+  (let ((mdhd       (tree:find-tree (mp4-atoms mp4-file) (lambda (x) (= (atom-type (tree:data x)) +audioprop-mdhd+))))
+        (audioprop1 (tree:find-tree (mp4-atoms mp4-file) (lambda (x) (= (atom-type (tree:data x)) +audioprop-mp4a+))))
+        (audioprop2 (tree:find-tree (mp4-atoms mp4-file) (lambda (x) (= (atom-type (tree:data x)) +audioprop-esds+)))))
+
     (if (and mdhd audioprop1 audioprop2)
-        (values (first mdhd) (first audioprop1) (first audioprop2))
+        (values (tree:data (first mdhd))
+                (tree:data (first audioprop1))
+                (tree:data (first audioprop2)))
         nil)))
 
 (defclass audio-info ()
@@ -573,19 +574,18 @@ Written in this fashion so as to be 'crash-proof' when passed an arbitrary file.
 (defun get-mp4-audio-info (mp4-file)
   "MP4A audio info is held in under the trak.mdia.mdhd/trak.mdia.minf.stbl/trak.mdia.minf.stbl.mp4a atoms."
   (declare #.utils:*standard-optimize-settings*)
-  t)
-  ;; (let ((info (make-instance 'audio-info)))
-  ;;   (multiple-value-bind (mdhd mp4a esds) (get-audio-properties-atoms mp4-file)
-  ;;     (with-slots (seconds channels bits-per-sample sample-rate max-bit-rate avg-bit-rate) info
-  ;;       (when mdhd
-  ;;         (setf seconds (/ (float (duration mdhd)) (float (scale mdhd)))))
-  ;;       (when mp4a
-  ;;         (setf channels (num-chans mp4a)
-  ;;               bits-per-sample (samp-size mp4a))
-  ;;         (let* ((upper (ash (samp-rate mp4a) -16))
-  ;;                (lower (logand (samp-rate mp4a) #xffff)))
-  ;;           (setf sample-rate (+ (float upper) (/ (float lower) 1000))))
-  ;;       (when esds
-  ;;         (setf avg-bit-rate (avg-bit-rate esds)
-  ;;               max-bit-rate (max-bit-rate esds))))))
-  ;;   info))
+  (let ((info (make-instance 'audio-info)))
+    (multiple-value-bind (mdhd mp4a esds) (get-audio-properties-atoms mp4-file)
+      (with-slots (seconds channels bits-per-sample sample-rate max-bit-rate avg-bit-rate) info
+        (when mdhd
+          (setf seconds (/ (float (duration mdhd)) (float (scale mdhd)))))
+        (when mp4a
+          (setf channels (num-chans mp4a)
+                bits-per-sample (samp-size mp4a))
+          (let* ((upper (ash (samp-rate mp4a) -16))
+                 (lower (logand (samp-rate mp4a) #xffff)))
+            (setf sample-rate (+ (float upper) (/ (float lower) 1000))))
+        (when esds
+          (setf avg-bit-rate (avg-bit-rate esds)
+                max-bit-rate (max-bit-rate esds))))))
+    info))

tree.lisp

@@ -2,40 +2,50 @@
 ;;; Copyright (c) 2013, Mark VandenBrink. All rights reserved.
 (in-package #:tree)
 
+(declaim (inline #:first-child #:add-child #:next-sibling #:data))
+
 (defun make-node (data)
   "Creates a new node with DATA as contents"
+  (declare #.utils:*standard-optimize-settings*)
   (cons (cons data nil) nil))
 
 (defun add-child (node child)
   "Takes two nodes created with MAKE-NODE and adds CHILD"
+  (declare #.utils:*standard-optimize-settings*)
   (nconc (first node) child)
   node)
 
 (defun first-child (node)
   "Returns a reference to the first child of NODE"
+  (declare #.utils:*standard-optimize-settings*)
   (rest (first node)))
 
 (defun next-sibling (node)
   "Returns next SIBLING of NODE"
+  (declare #.utils:*standard-optimize-settings*)
   (rest node))
 
 (defun data (node)
   "Returns the information in NODE"
+  (declare #.utils:*standard-optimize-settings*)
   (first (first node)))
 
 (defun traverse (tree func &optional (depth 0))
   "Depth-first traversal of TREE calling FUNC for each node"
+  (declare #.utils:*standard-optimize-settings*)
   (when tree
-    (funcall func (data tree) depth)
+    (funcall func tree depth)
     (traverse (first-child tree) func (+ 2 depth))
     (traverse (next-sibling tree) func depth)))
 
 (defun print-tree (tree)
   "Print the nodes of TREE"
-  (traverse tree (lambda (node depth) (format t "~v@tNode: ~a~%" depth node))))
+  (declare #.utils:*standard-optimize-settings*)
+  (traverse tree (lambda (node depth) (format t "~v@tNode: ~a~%" depth (data node)))))
 
 (defun find-tree (tree test)
   "Find all nodes in TREE where TEST returns T"
+  (declare #.utils:*standard-optimize-settings*)
   (let ((results))
     (traverse tree (lambda (node depth)
                      (declare (ignore depth))
@@ -43,5 +53,21 @@
                        (push node results))))
     (nreverse results)))
 
+(defun at-path (tree path cmp)
+  "Return node from TREE located at PATH"
+  (declare #.utils:*standard-optimize-settings*)
+
+  (when (or (null tree) (null path))
+    (return-from at-path nil))
+
+  (when (funcall cmp tree (first path))
+    (when (= 1 (length path))
+      (return-from at-path tree))
+    (loop for node = (first-child tree) then (next-sibling node)
+          until (null node) do
+            (utils:aif (at-path node (rest path) cmp)
+                       (return-from at-path utils:it))))
+  nil)
+
 (let ((pkg (find-package :tree)))
   (do-all-symbols (sym pkg) (when (eql (symbol-package sym) pkg) (export sym pkg))))