Ugarit Manifest Maker: Check-in [65f90322e5]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview

Comment:	OGG metadata parsing, and -Dfoo="bar" for defaults.
Downloads:	Tarball \| ZIP archive \| SQL archive
Timelines:	family \| ancestors \| descendants \| both \| trunk
Files:	files \| file ages \| folders
SHA1:	65f90322e5274b62cc6729c73ae2fc53012752ab
User & Date:	alaric 2015-05-28 11:23:10

Context

2015-06-12
19:50		Sorted directories in the manifest maker, fixed a typo in a property name, and moved to using "mtime" rather than "dc:modified", to reflect that it is just a POSIX filesystem attribute rather than anything relating to the actual content, and keeping compatability as such with existing Ugarit conventions. check-in: 6caa1bd9ec user: alaric tags: trunk
2015-05-28
11:23		OGG metadata parsing, and -Dfoo="bar" for defaults. check-in: 65f90322e5 user: alaric tags: trunk
2015-05-09
14:44		Moved to Dublin Core metadata where possible. check-in: 7eb028a964 user: alaric tags: trunk

Changes

Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ugarit-manifest-maker.scm.

(use posix)
(use srfi-1)


(use ugarit-mime)
(use srfi-37)
(use miscmacros)
(use fnmatch)
(use exif)

(define *excludes* '())
................................................................................
    (dc:subject . #f)))

(define debug (lambda x (void)))
#;(define debug printf)

(define (alist-update! alist key value)
  (let ((pair (assq key alist)))
    (if (and (pair? pair) (not (cdr pair)))

        (begin
          (set-cdr! pair value) ;; Exists but is #f, so overwrite
          alist)
        (cons (cons key value) alist))))

(define genres
  '((0 . "Blues")
................................................................................
      str
      (if (char=? (string-ref str
                              (- (string-length str) 1))
                  #\x00)
          (substring str 0 (- (string-length str) 1))
          str)))


























































(define (get-mp3-metadata path)
  ;; FIXME http://id3.org/id3v2-00 / http://id3.org/id3v2.3.0
  (with-input-from-file path
    (lambda ()
      (let/cc
       abort*
       (let* ((metadata
               '((creator . #f)
                 (creation-date . #f)
................................................................................
                 (collection-name . #f)
                 (collection-volume . #f)
                 (collection-volumes . #f)
                 (volume-index . #f)
                 (volume-size . #f)))
              (abort
               (lambda ()

                 (abort* metadata)))
              (read-id3v22
               (lambda ()
                 (debug "Reading v2.2")
                 (let* ((flags (read-byte))
                        (unsync (not (zero? (bitwise-and flags 128))))
                        (compressed (not (zero? (bitwise-and flags 64))))
                        (size4 (read-byte))
                        (size3 (read-byte))
                        (size2 (read-byte))
                        (size1 (read-byte))
................................................................................
                            (fsize3 (rb))
                            (fsize2 (rb))
                            (fsize1 (rb))
                            (fsize (+
                                    fsize1
                                    (* 256 fsize2)
                                    (* 65536 fsize3)))
                            (encoding (rb))
                            (data
                             (remove-trailing-term-if-present
                              (list->string
                               (reverse
                                (list-tabulate
                                 (- fsize 1) ;; Remove encoding byte
                                 (lambda (i) (integer->char (rb)))))))))


                       (debug "FID: ~S size: ~S [~S]\n" fid fsize data)
                       (cond
                        ((string=? fid "\x00\x00\x00")
                         (abort* md))
                        ((string=? fid "TT2")
                         (loop (alist-update! md 'dc:title data)))
                        ((string=? fid "TP1")
................................................................................
                                 fid
                                 (string-append
                                  (make-string 1 (integer->char encoding))
                                  data))
                         (loop md))))))))
              (read-id3v23
               (lambda ()
                 (debug "Reading v2.3")
                 (let* ((flags (read-byte))
                        (unsync (not (zero? (bitwise-and flags 128))))
                        (extended (not (zero? (bitwise-and flags 64))))
                        (experimental (not (zero? (bitwise-and flags 32))))
                        (size4 (read-byte))
                        (size3 (read-byte))
                        (size2 (read-byte))
................................................................................
                            (fsize (+
                                    fsize1
                                    (* 256 fsize2)
                                    (* 65536 fsize3)
                                    (* 16777216 fsize4)))
                            (flags1 (rb))
                            (flags2 (rb))
                            (encoding (rb))
                            (data
                             (remove-trailing-term-if-present
                              (list->string
                               (reverse
                                (list-tabulate
                                 (- fsize 1) ;; Remove encoding byte
                                 (lambda (i) (integer->char (rb)))))))))


                       (debug "FID: ~S size: ~S [~S]\n" fid fsize data)
                       (cond
                        ((string=? fid "\x00\x00\x00\x00")
                         (abort* md))
                        ((string=? fid "TIT2")
                         (loop (alist-update! md 'dc:title data)))
                        ((string=? fid "TPE1")
................................................................................
              (abort))
        (let ((version1 (read-byte))
              (version2 (read-byte)))
          (case version1
            ((2) (read-id3v22))
            ((3) (read-id3v23))
            (else (abort)))))))))















































































































(define (get-ogg-metadata path)

  ;; FIXME http://xiph.org/vorbis/doc/v-comment.html





  '((creator . #f)
    (creation-date . #f)
    (featuring . #f)
    (collection-name . #f)
    (collection-volume . #f)
    (collection-volumes . #f)
    (volume-index . #f)
    (volume-size . #f)))



























































(define (get-pdf-metadata path)
  '((dc:creator . #f)
    (dc:subject . #f)
    (dc:description . #f)
    (dc:created . #f)
    (dc:identifier . #f)
................................................................................
                     (printf "  (~S = ~S)\n" (car item) (cdr item))
                     (printf "  #;(~S = \"\")\n" (car item)))))
              (mime-type (extension->mimetype (string-append "."
                                                             (or
                                                              (pathname-extension path)
                                                              "")))))
         (printf "(object ~S\n" path)
         (printf "  (filename = ~S)\n" path)
         (printf "  (dc:format = ~S)\n" mime-type)
         (for-each print-item *defaults*)

         (newline)

         (cond
          ((string=? mime-type "image/jpeg")
           (for-each print-item
                     (get-jpeg-metadata path)))
................................................................................
          ((string=? mime-type "application/postscript")
           (for-each print-item
                     (get-ps-metadata path)))

          (else
           (unless *got-name*
                   (printf "  (dc:title = ~S)\n" name))
           (printf "  #;(description = \"\")\n")))



         (newline)

         (let ((stat (file-stat path)))
           (printf "  (dc:modified = ~S)\n" (vector-ref stat 8))
           (printf "  (ctime = ~S)\n" (vector-ref stat 7)))

................................................................................
       vals))
    (option
     '(#\D "define") #t #f
     (lambda (o n x vals)
       (let ((pos (string-index x #\=)))
         (unless pos
                 (usage))
         (let ((key (string-take x pos))
               (value (string-drop x (+ pos 1))))
          (push! (cons key value) *defines*)))
       vals)))
   (lambda (o n x vals)
     (usage))
   cons
   '()))




>







 







|
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

|







 







>



|







 







|
|
|
|
|
|
|
|
>
>







 







|







 







|
|
|
|
|
|
|
|
>
>







 








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>

>
|
>
>
>
>
>
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|

|







 







|
>
>







 







|
|

(use posix)
(use srfi-1)

(use numbers)
(use ugarit-mime)
(use srfi-37)
(use miscmacros)
(use fnmatch)
(use exif)

(define *excludes* '())
................................................................................
    (dc:subject . #f)))

(define debug (lambda x (void)))
#;(define debug printf)

(define (alist-update! alist key value)
  (let ((pair (assq key alist)))
    (if (and (pair? pair)
             (not (cdr pair)))
        (begin
          (set-cdr! pair value) ;; Exists but is #f, so overwrite
          alist)
        (cons (cons key value) alist))))

(define genres
  '((0 . "Blues")
................................................................................
      str
      (if (char=? (string-ref str
                              (- (string-length str) 1))
                  #\x00)
          (substring str 0 (- (string-length str) 1))
          str)))

(define (read-utf16-be bytes rb)
  (let ((str (make-string (/ bytes 2))))
    (dotimes (idx (/ bytes 2))
             (let* ((ch1 (rb))
                    (ch2 (rb)))
               (string-set! str idx
                            (integer->char
                             (+ (* ch1 256)
                                ch2)))))
    str))

(define (read-utf16-le bytes rb)
  (let ((str (make-string (/ bytes 2))))
    (dotimes (idx (/ bytes 2))
             (let* ((ch2 (rb))
                    (ch1 (rb)))
               (string-set! str idx
                            (integer->char
                             (+ (* ch1 256)
                                ch2)))))
    str))

(define (load-id3-string encoding bytes rb)
  (case encoding
   ((0)
    (let ((str (make-string bytes)))
      (dotimes (idx bytes)
               (string-set! str idx (integer->char (rb))))
      str))
   ((1)
    ;; Look for a BOM
    (if (or (< bytes 2)
            (not (zero? (remainder bytes 2))))
        (let ((str (make-string bytes)))
          (dotimes (idx bytes)
                   (string-set! str idx (integer->char (rb))))
          (sprintf "Invalid UTF16 [~S]" str))
        (begin
          (let* ((ch1 (rb))
                 (ch2 (rb)))
            (cond
             ((and (= ch1 #xff)
                   (= ch2 #xfe))
              (read-utf16-le (- bytes 2) rb))
             ((and (= ch1 #xfe)
                   (= ch2 #xff))
              (read-utf16-be (- bytes 2) rb))
             (else
              (string-append
               (make-string 1 (integer->char (+ (* 256 ch1) ch2)))
               (read-utf16-be (- bytes 2) rb))))))))
   (else
    (let ((str (make-string bytes)))
      (dotimes (idx bytes)
               (string-set! str idx (integer->char (rb))))
      (sprintf "Unknown encoding [~S] [~S]" encoding str)))))

(define (get-mp3-metadata path)
  ;; http://id3.org/id3v2-00 / http://id3.org/id3v2.3.0
  (with-input-from-file path
    (lambda ()
      (let/cc
       abort*
       (let* ((metadata
               '((creator . #f)
                 (creation-date . #f)
................................................................................
                 (collection-name . #f)
                 (collection-volume . #f)
                 (collection-volumes . #f)
                 (volume-index . #f)
                 (volume-size . #f)))
              (abort
               (lambda ()
                 (printf "   ;; Could not read metadata\n")
                 (abort* metadata)))
              (read-id3v22
               (lambda ()
                 (debug "Reading v2.2\n")
                 (let* ((flags (read-byte))
                        (unsync (not (zero? (bitwise-and flags 128))))
                        (compressed (not (zero? (bitwise-and flags 64))))
                        (size4 (read-byte))
                        (size3 (read-byte))
                        (size2 (read-byte))
                        (size1 (read-byte))
................................................................................
                            (fsize3 (rb))
                            (fsize2 (rb))
                            (fsize1 (rb))
                            (fsize (+
                                    fsize1
                                    (* 256 fsize2)
                                    (* 65536 fsize3)))
                            (encoding (if (char=? (integer->char fid1) #\T)
                                          (rb)
                                          0))
                            (remaining-size
                             (if (char=? (integer->char fid1) #\T)
                                 (- fsize 1)
                                 fsize))
                            (data
                             (remove-trailing-term-if-present
                              (load-id3-string encoding remaining-size rb))))
                       (debug "FID: ~S size: ~S [~S]\n" fid fsize data)
                       (cond
                        ((string=? fid "\x00\x00\x00")
                         (abort* md))
                        ((string=? fid "TT2")
                         (loop (alist-update! md 'dc:title data)))
                        ((string=? fid "TP1")
................................................................................
                                 fid
                                 (string-append
                                  (make-string 1 (integer->char encoding))
                                  data))
                         (loop md))))))))
              (read-id3v23
               (lambda ()
                 (debug "Reading v2.3\n")
                 (let* ((flags (read-byte))
                        (unsync (not (zero? (bitwise-and flags 128))))
                        (extended (not (zero? (bitwise-and flags 64))))
                        (experimental (not (zero? (bitwise-and flags 32))))
                        (size4 (read-byte))
                        (size3 (read-byte))
                        (size2 (read-byte))
................................................................................
                            (fsize (+
                                    fsize1
                                    (* 256 fsize2)
                                    (* 65536 fsize3)
                                    (* 16777216 fsize4)))
                            (flags1 (rb))
                            (flags2 (rb))
                            (encoding (if (char=? (integer->char fid1) #\T)
                                          (rb)
                                          0))
                            (remaining-size
                             (if (char=? (integer->char fid1) #\T)
                                 (- fsize 1)
                                 fsize))
                            (data
                             (remove-trailing-term-if-present
                              (load-id3-string encoding remaining-size rb))))
                       (debug "FID: ~S size: ~S [~S]\n" fid fsize data)
                       (cond
                        ((string=? fid "\x00\x00\x00\x00")
                         (abort* md))
                        ((string=? fid "TIT2")
                         (loop (alist-update! md 'dc:title data)))
                        ((string=? fid "TPE1")
................................................................................
              (abort))
        (let ((version1 (read-byte))
              (version2 (read-byte)))
          (case version1
            ((2) (read-id3v22))
            ((3) (read-id3v23))
            (else (abort)))))))))

(define (read-ogg-lacing)
  (let loop ((lacing 0)
             (bytes 1))
    (let ((byte (read-byte)))
      (if (= byte 255)
          (loop (+ lacing byte) (+ bytes 1))
          (values bytes (+ lacing byte))))))

(define (read-ogg-page abort)
  (when (not (= (read-byte) #x4f)) ;; OggS magic number
        (abort))
  (when (not (= (read-byte) #x67))
        (abort))
  (when (not (= (read-byte) #x67))
        (abort))
  (when (not (= (read-byte) #x53))
        (abort))
  (when (not (= (read-byte) #x00)) ;; Version
        (abort))
  (read-byte) ;; Header type
  (read-byte) ;; Granule position
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte) ;; Stream serial number
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte) ;; Page sequence number
  (read-byte)
  (read-byte)
  (read-byte)
  (read-byte) ;; Page checksum
  (read-byte)
  (read-byte)
  (read-byte)
  (let ((segments (read-byte)))
    (let ((segment-sizes
           (reverse
            (let loop ((segments-left segments)
                       (segment-sizes '()))
              (if (zero? segments-left)
                  segment-sizes
                  (receive (bytes lacing)
                           (read-ogg-lacing)
                           (loop (- segments-left bytes)
                                 (cons lacing segment-sizes))))))))
      (let loop ((ss segment-sizes)
                 (segments '()))
        (if (null? ss)
            (reverse segments)
            (let ((data (read-string (car ss))))
              (loop (cdr ss)
                    (cons data segments))))))))

(define (read-ogg-u32)
  (let* ((s1 (read-byte))
         (s2 (read-byte))
         (s3 (read-byte))
         (s4 (read-byte)))
    (+
     s1
     (* 256 s2)
     (* 65536 s3)
     (* 16777216 s4))))

(define (read-ogg-string)
  (let ((length (read-ogg-u32)))
    (read-string length)))

(define (parse-ogg-comment str)
  (let ((sep-pos (string-index str #\=)))
    (if sep-pos
        (cons (string-take str sep-pos)
              (string-drop str (+ sep-pos 1)))
        str)))

(define (parse-ogg-comments comments abort)
  (with-input-from-string comments
    (lambda ()
      (let ((type (read-byte)))
        (unless (= type 3)
                (abort)))
      (unless (= (read-byte) #x76) #; "vorbis"
              (abort))
      (unless (= (read-byte) #x6f)
              (abort))
      (unless (= (read-byte) #x72)
              (abort))
      (unless (= (read-byte) #x62)
              (abort))
      (unless (= (read-byte) #x69)
              (abort))
      (unless (= (read-byte) #x73)
              (abort))
      (let ((vendor (read-ogg-string)))
        (debug "Vendor: [~S]\n" vendor))
      (let loop ((comments-left (read-ogg-u32))
                 (comments '()))
        (if (zero? comments-left)
            comments
            (begin
              (loop (- comments-left 1)
                    (cons (parse-ogg-comment (read-ogg-string)) comments))))))))


(define (get-ogg-metadata path)
  ;; http://xiph.org/vorbis/doc/framing.html
  ;; http://xiph.org/vorbis/doc/v-comment.html
  (with-input-from-file path
    (lambda ()
      (let/cc
       abort*
       (let* ((metadata
               '((creator . #f)
                 (creation-date . #f)
                 (featuring . #f)
                 (collection-name . #f)
                 (collection-volume . #f)
                 (collection-volumes . #f)
                 (volume-index . #f)
                 (volume-size . #f)))
              (abort
               (lambda ()
                 (printf "   ;; Could not read metadata\n")
                 (abort* metadata))))
         ;; Skip header
         (read-ogg-page abort)
         ;; Read comment header
         (let* ((comments-page (read-ogg-page abort))
                (comments-packet (first comments-page))
                (comments (parse-ogg-comments comments-packet abort)))
           ;; Process comments
           (let loop ((md (alist-copy metadata))
                      (comments comments))
             (if (null? comments)
                 md
                 (let ((key (car (car comments)))
                       (value (cdr (car comments))))
                   (cond
                    ((string-ci= key "artist")
                     (loop (alist-update! md 'cd:creator value)
                           (cdr comments)))
                    ((string-ci= key "performer")
                     (loop (alist-update! md 'dc:contributor value)
                           (cdr comments)))
                    ((string-ci= key "producer")
                     (loop (alist-update! md 'dc:contributor value)
                           (cdr comments)))
                    ((string-ci= key "title")
                     (loop (alist-update! md 'dc:title value)
                           (cdr comments)))
                    ((string-ci= key "album")
                     (loop (alist-update! md 'set:title value)
                           (cdr comments)))
                    ((string-ci= key "tracknumber")
                     (loop (alist-update! md 'set:index value)
                           (cdr comments)))
                    ((string-ci= key "totaltracks")
                     (loop (alist-update! md 'set:size value)
                           (cdr comments)))
                    ((string-ci= key "discnumber")
                     (loop (alist-update! md 'superset:index value)
                           (cdr comments)))
                    ((string-ci= key "totaldiscs")
                     (loop (alist-update! md 'superset:size value)
                           (cdr comments)))
                    ((string-ci= key "date")
                     (loop (alist-update! md 'dc:created value)
                           (cdr comments)))
                    ((string-ci= key "originaldate")
                     (loop (alist-update! md 'dc:created value)
                           (cdr comments)))
                    ((string-ci= key "genre")
                     (loop (alist-update! md 'dc:subject value)
                           (cdr comments)))
                    (else
                     (printf "   ;; Unknown Ogg tag ~S=~S\n"
                             key value)
                     (loop md (cdr comments)))))))))))))

(define (get-pdf-metadata path)
  '((dc:creator . #f)
    (dc:subject . #f)
    (dc:description . #f)
    (dc:created . #f)
    (dc:identifier . #f)
................................................................................
                     (printf "  (~S = ~S)\n" (car item) (cdr item))
                     (printf "  #;(~S = \"\")\n" (car item)))))
              (mime-type (extension->mimetype (string-append "."
                                                             (or
                                                              (pathname-extension path)
                                                              "")))))
         (printf "(object ~S\n" path)
         (printf "  (filename = ~S)\n" (pathname-strip-directory path))
         (printf "  (dc:format = ~S)\n" mime-type)
         (for-each print-item *defines*)

         (newline)

         (cond
          ((string=? mime-type "image/jpeg")
           (for-each print-item
                     (get-jpeg-metadata path)))
................................................................................
          ((string=? mime-type "application/postscript")
           (for-each print-item
                     (get-ps-metadata path)))

          (else
           (unless *got-name*
                   (printf "  (dc:title = ~S)\n" name))
           (printf "  #;(description = \"\")\n")
           (printf "  ;; No metadata extraction available for ~S files"
                   (pathname-extension path))))

         (newline)

         (let ((stat (file-stat path)))
           (printf "  (dc:modified = ~S)\n" (vector-ref stat 8))
           (printf "  (ctime = ~S)\n" (vector-ref stat 7)))

................................................................................
       vals))
    (option
     '(#\D "define") #t #f
     (lambda (o n x vals)
       (let ((pos (string-index x #\=)))
         (unless pos
                 (usage))
         (let ((key (string->symbol (string-take x pos)))
               (value (with-input-from-string (string-drop x (+ pos 1)) read)))
          (push! (cons key value) *defines*)))
       vals)))
   (lambda (o n x vals)
     (usage))
   cons
   '()))