| 1 | #!/usr/bin/guile -s |
| 2 | !# |
| 3 | |
| 4 | ;;; -*- scheme -*- |
| 5 | |
| 6 | ;;; Parse for enhanced XMCD. Original format: http://ftp.freedb.org/pub/freedb/latest/DBFORMAT |
| 7 | |
| 8 | (use-modules (ice-9 format) |
| 9 | (ice-9 rdelim) |
| 10 | (ice-9 streams) |
| 11 | (ice-9 regex) |
| 12 | (ice-9 vlist) |
| 13 | |
| 14 | (srfi srfi-1)) |
| 15 | |
| 16 | ;;; VList/VHash utility functions |
| 17 | |
| 18 | (define (vhash-cat key new-value vhash) |
| 19 | "Add NEW-VALUE to the VList stored under VHASH.KEY" |
| 20 | (vhash-set key (vlist-append (let ((lst (vhash-assoc key vhash))) |
| 21 | (if lst (cdr lst) vlist-null)) |
| 22 | (vlist-cons new-value vlist-null)) |
| 23 | vhash)) |
| 24 | |
| 25 | (define (vhash-set key new-value vhash) |
| 26 | (vhash-cons key new-value (vhash-delete key vhash))) |
| 27 | |
| 28 | |
| 29 | ;;; Simple key/value database for cddb and toc info |
| 30 | |
| 31 | ;;; DO NOT RELY ON THE IMPLEMENTATION, it sucks. Always use the query |
| 32 | ;;; functions. The disc query functions return the list of values, the |
| 33 | ;;; track query functions return an alist of (track-num |
| 34 | ;;; . values). Values are always plural, just grab the car if you want |
| 35 | ;;; a single value. It's not the best interface, but it sure beats |
| 36 | ;;; grepping the xmcd file! |
| 37 | |
| 38 | (define (make-initial-db . toplevel-keys) |
| 39 | (fold (lambda (key db) (vhash-cons key vlist-null db)) vlist-null toplevel-keys)) |
| 40 | |
| 41 | (define (cddb-query-disc db tag) |
| 42 | "Query the database for a disc attribute" |
| 43 | (let ((result (vhash-assoc tag (cdr (vhash-assoc 'disc db))))) |
| 44 | (if result (vlist->list (cdr result)) #f))) |
| 45 | |
| 46 | (define (cddb-query-tracks db tag) |
| 47 | "Query the database for a track attribute and return alist |
| 48 | of (disc-number . tag-value)" |
| 49 | (let ((r (vlist->list (vhash-fold (lambda (key vh results) |
| 50 | (let ((result (vhash-assoc tag vh))) |
| 51 | (if result |
| 52 | (vhash-cons key (vlist->list (cdr result)) results) |
| 53 | results))) |
| 54 | vlist-null |
| 55 | (cdr (vhash-assoc 'tracks db)))))) |
| 56 | (if (null? r) #f r))) |
| 57 | |
| 58 | (define (read-cddb cddb-port) |
| 59 | (define (parse-cddb-line line db) |
| 60 | (define (line-match regex) (string-match regex line)) |
| 61 | |
| 62 | (cond |
| 63 | ((line-match "^#(.*)$") => (lambda (x) (vhash-cat 'comment (match:substring x 1) db))) |
| 64 | ((line-match "^DISCID=([[:graph:]]+)$") => (lambda (x) (let ((disc-db (cdr (vhash-assoc 'disc db)))) |
| 65 | (vhash-set 'disc (vhash-cat 'DISCID (match:substring x 1) disc-db) |
| 66 | db)))) |
| 67 | ((line-match "^D([[:alpha:]]+)=([[:graph:][:space:]]+)$") => (lambda (x) |
| 68 | (let ((disc-db (cdr (vhash-assoc 'disc db))) |
| 69 | (key (string->symbol (match:substring x 1)))) |
| 70 | (vhash-set 'disc (vhash-cat key (match:substring x 2) disc-db) |
| 71 | db)))) |
| 72 | |
| 73 | ((line-match "^T([[:alpha:]]+)([[:digit:]]+)=([[:graph:][:space:]]+)$") |
| 74 | => (lambda (x) |
| 75 | (let* ((tracks-db (cdr (vhash-assoc 'tracks db))) |
| 76 | (tracknum (string->number (match:substring x 2))) |
| 77 | (tracknum-db ((lambda (vh) (if vh (cdr vh) vlist-null)) (vhash-assoc tracknum tracks-db))) |
| 78 | (key (string->symbol (match:substring x 1))) |
| 79 | (tag-value (match:substring x 3))) |
| 80 | (vhash-set 'tracks (vhash-set tracknum (vhash-cat key tag-value tracknum-db) |
| 81 | tracks-db) |
| 82 | db)))) |
| 83 | |
| 84 | ;; Also match EXTD? Might just punt if abcde handles it separately |
| 85 | (else db))) |
| 86 | |
| 87 | (stream-fold parse-cddb-line |
| 88 | (make-initial-db 'comment 'disc 'tracks) |
| 89 | (port->stream cddb-port read-line))) |
| 90 | |
| 91 | ;;; Commands |
| 92 | |
| 93 | ;; string-tokenize is weird, might want to just use regexeps instead |
| 94 | (define cddb-dtitle-char-set (char-set-difference char-set:printing |
| 95 | (char-set #\/))) |
| 96 | |
| 97 | (define* (cddb->export cddb #:optional (out (current-output-port))) |
| 98 | "Convert database to shell expression for abcde" |
| 99 | ;; Using single quoting instead of "" to make life easier |
| 100 | (letrec* ((escape-for-shell |
| 101 | (lambda (x) (regexp-substitute/global #f "['\\\\]" x |
| 102 | 'pre |
| 103 | (lambda (m) (string-append "\\" (match:substring m))) |
| 104 | 'post))) |
| 105 | (disc-query (lambda* (key #:optional (default '(""))) |
| 106 | (cond ((cddb-query-disc cddb key) => identity) |
| 107 | (else default)))) |
| 108 | |
| 109 | (artist ((lambda (s) (substring s 0 (- (string-index s #\/) 1))) (car (disc-query 'TITLE))) |
| 110 | |
| 111 | #;(string-trim-right (car (string-tokenize (car (disc-query 'TITLE)) cddb-dtitle-char-set)))) |
| 112 | |
| 113 | (album ((lambda (s) (substring s (+ (string-index s #\/) 2))) (car (disc-query 'TITLE))) |
| 114 | #;(string-trim (string-join (cdr (string-tokenize (car (disc-query 'TITLE)) cddb-dtitle-char-set)) |
| 115 | "/")))) |
| 116 | |
| 117 | |
| 118 | (newline out) |
| 119 | |
| 120 | ;; Not exported CDDBGENRE intentionally, since it appears unused |
| 121 | (format out "DISCID=$'~A'~%DALBUM=$'~A'~%DARTIST=$'~A'~%CDYEAR=$'~A'~%" |
| 122 | (escape-for-shell (car (disc-query 'DISCID))) |
| 123 | (escape-for-shell album) |
| 124 | (escape-for-shell artist) |
| 125 | (escape-for-shell (car (disc-query 'YEAR)))) |
| 126 | |
| 127 | ;; Store genre(s) in a bash array. mp3s will just have to live with |
| 128 | ;; using the first, but Vorbis/FLAC can handle an arbitrary set of |
| 129 | ;; genres |
| 130 | (format out "CDGENRE=(~{$'~A' ~})~%" (map escape-for-shell (disc-query 'GENRE))) |
| 131 | |
| 132 | (format out "~:{TRACK~A=$'~A'~%~}" |
| 133 | (map (lambda (ttitle) (list (1+ (first ttitle)) (escape-for-shell (second ttitle)))) |
| 134 | (cddb-query-tracks cddb 'TITLE))))) |
| 135 | |
| 136 | (define (main args) |
| 137 | (cond ((string= (second args) "parse") |
| 138 | (call-with-input-file (third args) |
| 139 | (lambda (f) (cddb->export (read-cddb f))))) |
| 140 | (else |
| 141 | (apply execlp "cddb-tool" args)))) |
| 142 | |
| 143 | |
| 144 | (when (batch-mode?) |
| 145 | (exit (main (program-arguments)))) |