537 lines
20 KiB
Racket
537 lines
20 KiB
Racket
(module taglib racket/base
|
|
|
|
(require "taglib-ffi.rkt"
|
|
"private/utils.rkt"
|
|
ffi/unsafe
|
|
racket/class
|
|
racket/draw
|
|
racket/string)
|
|
|
|
(provide id3-tags
|
|
call-with-id3-tags
|
|
|
|
tags-valid?
|
|
tags-read-write?
|
|
tags-closed?
|
|
tags-close!
|
|
tags-save!
|
|
|
|
tags-title
|
|
tags-album
|
|
tags-artist
|
|
tags-comment
|
|
tags-year
|
|
tags-genre
|
|
tags-track
|
|
tags-composer
|
|
tags-disc-number
|
|
tags-album-artist
|
|
|
|
tags-title!
|
|
tags-album!
|
|
tags-artist!
|
|
tags-comment!
|
|
tags-year!
|
|
tags-genre!
|
|
tags-track!
|
|
tags-composer!
|
|
tags-disc-number!
|
|
tags-album-artist!
|
|
|
|
tags-length
|
|
tags-sample-rate
|
|
tags-bit-rate
|
|
tags-channels
|
|
|
|
tags-keys
|
|
tags-ref
|
|
tags-set!
|
|
tags-set-values!
|
|
tags-append!
|
|
tags-clear!
|
|
|
|
tags-picture
|
|
tags-picture!
|
|
tags-append-picture!
|
|
tags-clear-picture!
|
|
tags-picture->bitmap
|
|
tags-picture->file
|
|
tags-picture->kind
|
|
tags-picture->mimetype
|
|
tags-picture->description
|
|
tags-picture->size
|
|
tags-picture->ext
|
|
|
|
tags->hash
|
|
|
|
make-tags-picture
|
|
make-tags-picture-from-bitmap
|
|
id3-picture?
|
|
id3-picture-mimetype
|
|
id3-picture-kind
|
|
id3-picture-size
|
|
id3-picture-bytes
|
|
id3-picture-description)
|
|
|
|
(define-struct id3-tag-struct (handle))
|
|
(define-struct id3-picture (mimetype kind size bytes description))
|
|
|
|
(define clear-tag-value 'clear)
|
|
|
|
(define (normal-mode mode)
|
|
(cond
|
|
[(or (eq? mode 'read) (eq? mode 'read-only)) 'read]
|
|
[(or (eq? mode 'write) (eq? mode 'read-write)) 'read-write]
|
|
[else (raise-argument-error 'id3-tags "(or/c 'read 'read-only 'read-write 'write)" mode)]))
|
|
|
|
(define (file->string file*)
|
|
(if (path? file*) (path->string file*) file*))
|
|
|
|
(define (copy-string s)
|
|
(if (eq? s #f) "" (string-append s "")))
|
|
|
|
(define (property-name k)
|
|
(cond
|
|
[(symbol? k) (string-upcase (symbol->string k))]
|
|
[(string? k) k]
|
|
[else (raise-argument-error 'tag-property "(or/c symbol? string?)" k)]))
|
|
|
|
(define (property-symbol k)
|
|
(string->symbol (string-downcase (property-name k))))
|
|
|
|
(define (first-property h key [default ""])
|
|
(let ((v (hash-ref h key #f)))
|
|
(cond
|
|
[(and (pair? v) (string? (car v))) (car v)]
|
|
[(string? v) v]
|
|
[else default])))
|
|
|
|
(define (first-property-number h key [default -1])
|
|
(let ((n (string->number (first-property h key (number->string default)))))
|
|
(if n n default)))
|
|
|
|
(define (string-list? v)
|
|
(and (list? v) (andmap string? v)))
|
|
|
|
(define (bitmap->encoded-bytes bm mimetype)
|
|
(define kind
|
|
(cond
|
|
[(or (string-ci=? mimetype "image/jpeg") (string-ci=? mimetype "image/jpg")) 'jpeg]
|
|
[(string-ci=? mimetype "image/png") 'png]
|
|
[else (error 'make-tags-picture-from-bitmap
|
|
"unsupported bitmap mimetype: ~a; use image/png or image/jpeg" mimetype)]))
|
|
(define out (open-output-bytes))
|
|
(unless (send bm save-file out kind)
|
|
(error 'make-tags-picture-from-bitmap "could not encode bitmap as ~a" mimetype))
|
|
(get-output-bytes out))
|
|
|
|
(define (make-tags-picture mimetype kind data #:description [description ""])
|
|
(define bytes
|
|
(cond
|
|
[(bytes? data) data]
|
|
[(is-a? data bitmap%) (bitmap->encoded-bytes data mimetype)]
|
|
[else (raise-argument-error 'make-tags-picture "(or/c bytes? (is-a?/c bitmap%))" data)]))
|
|
(make-id3-picture mimetype kind (bytes-length bytes) bytes description))
|
|
|
|
(define (make-tags-picture-from-bitmap bm kind #:mimetype [mimetype "image/png"] #:description [description ""])
|
|
(make-tags-picture mimetype kind bm #:description description))
|
|
|
|
(define (open-tag-file file)
|
|
(let ((tag-file (taglib_file_new file)))
|
|
(if (and tag-file (taglib_file_is_valid tag-file))
|
|
tag-file
|
|
(begin
|
|
(when (and tag-file (not (eq? tag-file #f))) (taglib_file_free tag-file))
|
|
(if (eq? (system-type 'os) 'windows)
|
|
(begin
|
|
(dbg-sound "Could not open file ~a, trying wchar version on windows" file)
|
|
(let ((wtag-file (taglib_file_new_wchar file)))
|
|
(if (and wtag-file (taglib_file_is_valid wtag-file)) wtag-file
|
|
(begin
|
|
(when (and wtag-file (not (eq? wtag-file #f))) (taglib_file_free wtag-file))
|
|
#f))))
|
|
#f)))))
|
|
|
|
(define (read-property-map tag-file)
|
|
(define key-store (make-hash))
|
|
(let* ((keys (taglib_property_keys tag-file))
|
|
(i 0)
|
|
(key (and keys (taglib_property_key keys i)))
|
|
(key-list '()))
|
|
(while (not (eq? key #f))
|
|
(set! key-list (append key-list (list (copy-string key))))
|
|
(set! i (+ i 1))
|
|
(set! key (taglib_property_key keys i)))
|
|
(for-each
|
|
(lambda (key)
|
|
(let ((props (taglib_property_get tag-file key)))
|
|
(let* ((vals '())
|
|
(i 0)
|
|
(val (and props (taglib_property_val props i))))
|
|
(while (not (eq? val #f))
|
|
(set! vals (append vals (list (copy-string val))))
|
|
(set! i (+ i 1))
|
|
(set! val (taglib_property_val props i)))
|
|
(when props (taglib_property_free props))
|
|
(hash-set! key-store (string->symbol (string-downcase key)) vals))))
|
|
key-list))
|
|
key-store)
|
|
|
|
(define (read-picture tag-file)
|
|
(let ((p (taglib-get-picture tag-file)))
|
|
(if (eq? p #f)
|
|
#f
|
|
(let ((mimetype (car p))
|
|
(description (cadr p))
|
|
(kind (caddr p))
|
|
(size (cadddr p))
|
|
(bytes (car (cddddr p))))
|
|
(make-id3-picture mimetype kind size bytes description)))))
|
|
|
|
(define (id3-tags file* #:mode [mode 'read])
|
|
(define file (file->string file*))
|
|
(define actual-mode (normal-mode mode))
|
|
(define read-write? (eq? actual-mode 'read-write))
|
|
(define valid? #f)
|
|
(define closed? #t)
|
|
(define tag-file #f)
|
|
(define tag #f)
|
|
(define title "")
|
|
(define album "")
|
|
(define artist "")
|
|
(define comment "")
|
|
(define year -1)
|
|
(define genre "")
|
|
(define track -1)
|
|
(define length -1)
|
|
(define sample-rate -1)
|
|
(define bit-rate -1)
|
|
(define channels -1)
|
|
(define key-store (make-hash))
|
|
(define composer "")
|
|
(define album-artist "")
|
|
(define disc-number -1)
|
|
(define picture #f)
|
|
|
|
(define (refresh-derived!)
|
|
(set! composer (first-property key-store 'composer ""))
|
|
(set! album-artist (first-property key-store 'albumartist ""))
|
|
(set! disc-number (first-property-number key-store 'discnumber -1)))
|
|
|
|
(define (open-and-read!)
|
|
(set! tag-file (open-tag-file file))
|
|
(if (eq? tag-file #f)
|
|
(begin
|
|
(set! valid? #f)
|
|
(warn-sound "Could not open file ~a" file))
|
|
(begin
|
|
(set! valid? #t)
|
|
(set! closed? #f)
|
|
(set! tag (taglib_file_tag tag-file))
|
|
(let ((ap (taglib_file_audioproperties tag-file)))
|
|
(set! title (copy-string (taglib_tag_title tag)))
|
|
(set! album (copy-string (taglib_tag_album tag)))
|
|
(set! artist (copy-string (taglib_tag_artist tag)))
|
|
(set! comment (copy-string (taglib_tag_comment tag)))
|
|
(set! genre (copy-string (taglib_tag_genre tag)))
|
|
(set! year (let ((v (taglib_tag_year tag))) (if (zero? v) -1 v)))
|
|
(set! track (let ((v (taglib_tag_track tag))) (if (zero? v) -1 v)))
|
|
(set! length (taglib_audioproperties_length ap))
|
|
(set! sample-rate (taglib_audioproperties_samplerate ap))
|
|
(set! bit-rate (taglib_audioproperties_bitrate ap))
|
|
(set! channels (taglib_audioproperties_channels ap))
|
|
(set! key-store (read-property-map tag-file))
|
|
(refresh-derived!)
|
|
(set! picture (read-picture tag-file))
|
|
(taglib_tag_free_strings)
|
|
(unless read-write? (close!))))))
|
|
|
|
(define (close!)
|
|
(unless closed?
|
|
(taglib_file_free tag-file)
|
|
(set! tag-file #f)
|
|
(set! tag #f)
|
|
(set! closed? #t))
|
|
(void))
|
|
|
|
(define (ensure-open! who)
|
|
(unless valid? (error who "tag handle is invalid: ~a" file))
|
|
(unless read-write?
|
|
(error who "tag handle is read-only for ~a; open with #:mode 'read-write" file))
|
|
(when closed? (error who "tag handle is closed: ~a" file)))
|
|
|
|
(define (set-property-cache! key vals)
|
|
(define sym (property-symbol key))
|
|
(if (null? vals) (hash-remove! key-store sym) (hash-set! key-store sym vals))
|
|
(refresh-derived!))
|
|
|
|
(define (string->cptr s)
|
|
(define bs (string->bytes/utf-8 s))
|
|
(define len (bytes-length bs))
|
|
(define ptr (malloc _byte (+ len 1) 'atomic-interior))
|
|
(for ([i (in-range len)]) (ptr-set! ptr _byte i (bytes-ref bs i)))
|
|
(ptr-set! ptr _byte len 0)
|
|
ptr)
|
|
|
|
(define (apply-string! who value setter cache!)
|
|
(ensure-open! who)
|
|
(cond
|
|
[(eq? value clear-tag-value) (setter tag "") (cache! "")]
|
|
[(string? value) (setter tag value) (cache! value)]
|
|
[else (raise-argument-error who "(or/c string? 'clear)" value)]))
|
|
|
|
(define (apply-uint! who value setter cache!)
|
|
(ensure-open! who)
|
|
(cond
|
|
[(eq? value clear-tag-value) (setter tag 0) (cache! -1)]
|
|
[(and (exact-nonnegative-integer? value) (<= value #xffffffff))
|
|
(setter tag value) (cache! value)]
|
|
[else (raise-argument-error who "(or/c exact-nonnegative-integer? 'clear)" value)]))
|
|
|
|
(define (set-one-property! who key value #:append? [append? #f])
|
|
(ensure-open! who)
|
|
(cond
|
|
[(eq? value clear-tag-value)
|
|
(if append?
|
|
(taglib_property_set_append tag-file (property-name key) #f)
|
|
(taglib_property_set tag-file (property-name key) #f))
|
|
(set-property-cache! key '())]
|
|
[(string? value)
|
|
(if append?
|
|
(taglib_property_set_append tag-file (property-name key) (string->cptr value))
|
|
(taglib_property_set tag-file (property-name key) (string->cptr value)))
|
|
(if append?
|
|
(set-property-cache! key (append (hash-ref key-store (property-symbol key) '()) (list value)))
|
|
(set-property-cache! key (list value)))]
|
|
[else (raise-argument-error who "(or/c string? 'clear)" value)]))
|
|
|
|
(define (set-values-property! key values)
|
|
(ensure-open! 'tags-set-values!)
|
|
(cond
|
|
[(eq? values clear-tag-value)
|
|
(taglib_property_set tag-file (property-name key) #f)
|
|
(set-property-cache! key '())]
|
|
[(string-list? values)
|
|
(taglib_property_set tag-file (property-name key) #f)
|
|
(for ([v values]) (taglib_property_set_append tag-file (property-name key) (string->cptr v)))
|
|
(set-property-cache! key values)]
|
|
[else (raise-argument-error 'tags-set-values! "(or/c (listof string?) 'clear)" values)]))
|
|
|
|
(define (set-picture! value #:append? [append? #f])
|
|
(ensure-open! (if append? 'tags-append-picture! 'tags-picture!))
|
|
(cond
|
|
[(eq? value clear-tag-value)
|
|
(unless (taglib-clear-picture tag-file)
|
|
(error 'tags-picture! "could not clear picture for file: ~a" file))
|
|
(set! picture #f)]
|
|
[(id3-picture? value)
|
|
(define ok?
|
|
(if append?
|
|
(taglib-append-picture tag-file
|
|
(id3-picture-mimetype value)
|
|
(id3-picture-kind value)
|
|
(id3-picture-description value)
|
|
(id3-picture-bytes value))
|
|
(taglib-set-picture tag-file
|
|
(id3-picture-mimetype value)
|
|
(id3-picture-kind value)
|
|
(id3-picture-description value)
|
|
(id3-picture-bytes value))))
|
|
(unless ok? (error (if append? 'tags-append-picture! 'tags-picture!)
|
|
"could not set picture for file: ~a" file))
|
|
(unless append? (set! picture value))]
|
|
[else (raise-argument-error (if append? 'tags-append-picture! 'tags-picture!)
|
|
"(or/c id3-picture? 'clear)" value)]))
|
|
|
|
(define (save!)
|
|
(ensure-open! 'tags-save!)
|
|
(taglib_file_save tag-file))
|
|
|
|
(define (to-hash)
|
|
(let ((h (make-hash)))
|
|
(hash-set! h 'valid? valid?)
|
|
(hash-set! h 'read-write? read-write?)
|
|
(hash-set! h 'closed? closed?)
|
|
(hash-set! h 'title title)
|
|
(hash-set! h 'album album)
|
|
(hash-set! h 'artist artist)
|
|
(hash-set! h 'comment comment)
|
|
(hash-set! h 'composer composer)
|
|
(hash-set! h 'genre genre)
|
|
(hash-set! h 'year year)
|
|
(hash-set! h 'track track)
|
|
(hash-set! h 'length length)
|
|
(hash-set! h 'sample-rate sample-rate)
|
|
(hash-set! h 'bit-rate bit-rate)
|
|
(hash-set! h 'channels channels)
|
|
(hash-set! h 'picture picture)
|
|
(hash-set! h 'keys (hash-keys key-store))
|
|
h))
|
|
|
|
(define (handle v . args)
|
|
(cond
|
|
[(eq? v 'valid?) valid?]
|
|
[(eq? v 'read-write?) read-write?]
|
|
[(eq? v 'closed?) closed?]
|
|
[(eq? v 'close!) (close!)]
|
|
[(eq? v 'save!) (save!)]
|
|
[(eq? v 'title) title]
|
|
[(eq? v 'album) album]
|
|
[(eq? v 'artist) artist]
|
|
[(eq? v 'comment) comment]
|
|
[(eq? v 'composer) composer]
|
|
[(eq? v 'genre) genre]
|
|
[(eq? v 'year) year]
|
|
[(eq? v 'track) track]
|
|
[(eq? v 'length) length]
|
|
[(eq? v 'sample-rate) sample-rate]
|
|
[(eq? v 'bit-rate) bit-rate]
|
|
[(eq? v 'channels) channels]
|
|
[(eq? v 'keys) (hash-keys key-store)]
|
|
[(eq? v 'album-artist) album-artist]
|
|
[(eq? v 'disc-number) disc-number]
|
|
[(eq? v 'val) (if (null? args) #f (hash-ref key-store (property-symbol (car args)) #f))]
|
|
[(eq? v 'picture) picture]
|
|
[(eq? v 'to-hash) (to-hash)]
|
|
[(eq? v 'set-title!) (apply-string! 'tags-title! (car args) taglib_tag_set_title (lambda (x) (set! title x)))]
|
|
[(eq? v 'set-album!) (apply-string! 'tags-album! (car args) taglib_tag_set_album (lambda (x) (set! album x)))]
|
|
[(eq? v 'set-artist!) (apply-string! 'tags-artist! (car args) taglib_tag_set_artist (lambda (x) (set! artist x)))]
|
|
[(eq? v 'set-comment!) (apply-string! 'tags-comment! (car args) taglib_tag_set_comment (lambda (x) (set! comment x)))]
|
|
[(eq? v 'set-genre!) (apply-string! 'tags-genre! (car args) taglib_tag_set_genre (lambda (x) (set! genre x)))]
|
|
[(eq? v 'set-year!) (apply-uint! 'tags-year! (car args) taglib_tag_set_year (lambda (x) (set! year x)))]
|
|
[(eq? v 'set-track!) (apply-uint! 'tags-track! (car args) taglib_tag_set_track (lambda (x) (set! track x)))]
|
|
[(eq? v 'set-composer!) (set-one-property! 'tags-composer! 'composer (car args))]
|
|
[(eq? v 'set-album-artist!) (set-one-property! 'tags-album-artist! 'albumartist (car args))]
|
|
[(eq? v 'set-disc-number!)
|
|
(let ((x (car args)))
|
|
(cond
|
|
[(eq? x clear-tag-value) (set-one-property! 'tags-disc-number! 'discnumber clear-tag-value)]
|
|
[(and (exact-nonnegative-integer? x) (<= x #xffffffff)) (set-one-property! 'tags-disc-number! 'discnumber (number->string x))]
|
|
[(string? x) (set-one-property! 'tags-disc-number! 'discnumber x)]
|
|
[else (raise-argument-error 'tags-disc-number! "(or/c exact-nonnegative-integer? string? 'clear)" x)]))]
|
|
[(eq? v 'set!) (set-one-property! 'tags-set! (car args) (cadr args))]
|
|
[(eq? v 'set-values!) (set-values-property! (car args) (cadr args))]
|
|
[(eq? v 'append!) (set-one-property! 'tags-append! (car args) (cadr args) #:append? #t)]
|
|
[(eq? v 'clear!) (set-one-property! 'tags-clear! (car args) clear-tag-value)]
|
|
[(eq? v 'set-picture!) (set-picture! (car args))]
|
|
[(eq? v 'append-picture!) (set-picture! (car args) #:append? #t)]
|
|
[(eq? v 'clear-picture!) (set-picture! clear-tag-value)]
|
|
[else (error (format "Unknown tag-cmd '~a'" v))]))
|
|
|
|
(open-and-read!)
|
|
(make-id3-tag-struct handle))
|
|
|
|
(define (call-with-id3-tags file proc #:mode [mode 'read])
|
|
(define tags (id3-tags file #:mode mode))
|
|
(dynamic-wind
|
|
void
|
|
(lambda () (proc tags))
|
|
(lambda () (tags-close! tags))))
|
|
|
|
(define-syntax def
|
|
(syntax-rules ()
|
|
((_ (fun v))
|
|
(define (fun tags . args)
|
|
(apply (id3-tag-struct-handle tags) (cons v args))))))
|
|
|
|
(define-syntax defs
|
|
(syntax-rules ()
|
|
((_ f1) (def f1))
|
|
((_ f1 f2 ...) (begin (def f1) (def f2) ...))))
|
|
|
|
(defs
|
|
(tags-valid? 'valid?)
|
|
(tags-read-write? 'read-write?)
|
|
(tags-closed? 'closed?)
|
|
(tags-close! 'close!)
|
|
(tags-save! 'save!)
|
|
|
|
(tags-title 'title)
|
|
(tags-album 'album)
|
|
(tags-artist 'artist)
|
|
(tags-comment 'comment)
|
|
(tags-genre 'genre)
|
|
(tags-composer 'composer)
|
|
(tags-album-artist 'album-artist)
|
|
(tags-disc-number 'disc-number)
|
|
(tags-year 'year)
|
|
(tags-track 'track)
|
|
|
|
(tags-title! 'set-title!)
|
|
(tags-album! 'set-album!)
|
|
(tags-artist! 'set-artist!)
|
|
(tags-comment! 'set-comment!)
|
|
(tags-genre! 'set-genre!)
|
|
(tags-composer! 'set-composer!)
|
|
(tags-album-artist! 'set-album-artist!)
|
|
(tags-disc-number! 'set-disc-number!)
|
|
(tags-year! 'set-year!)
|
|
(tags-track! 'set-track!)
|
|
|
|
(tags-length 'length)
|
|
(tags-sample-rate 'sample-rate)
|
|
(tags-bit-rate 'bit-rate)
|
|
(tags-channels 'channels)
|
|
|
|
(tags-keys 'keys)
|
|
(tags-ref 'val)
|
|
(tags-set! 'set!)
|
|
(tags-set-values! 'set-values!)
|
|
(tags-append! 'append!)
|
|
(tags-clear! 'clear!)
|
|
|
|
(tags-picture 'picture)
|
|
(tags-picture! 'set-picture!)
|
|
(tags-append-picture! 'append-picture!)
|
|
(tags-clear-picture! 'clear-picture!)
|
|
(tags->hash 'to-hash))
|
|
|
|
(define (tags-picture->bitmap tags)
|
|
(let ((p (tags-picture tags)))
|
|
(if (eq? p #f)
|
|
#f
|
|
(let* ((in (open-input-bytes (id3-picture-bytes p)))
|
|
(btm (read-bitmap in)))
|
|
(close-input-port in)
|
|
btm))))
|
|
|
|
(define (tags-picture->kind tags)
|
|
(let ((p (tags-picture tags)))
|
|
(if (eq? p #f) #f (id3-picture-kind p))))
|
|
|
|
(define (tags-picture->mimetype tags)
|
|
(let ((p (tags-picture tags)))
|
|
(if (eq? p #f) #f (id3-picture-mimetype p))))
|
|
|
|
(define (tags-picture->description tags)
|
|
(let ((p (tags-picture tags)))
|
|
(if (eq? p #f) #f (id3-picture-description p))))
|
|
|
|
(define (tags-picture->ext tags)
|
|
(let ((mt (tags-picture->mimetype tags)))
|
|
(cond
|
|
[(eq? mt #f) #f]
|
|
[(or (string-suffix? mt "/jpeg") (string-suffix? mt "/jpg")) 'jpg]
|
|
[(string-suffix? mt "/png") 'png]
|
|
[else #f])))
|
|
|
|
(define (tags-picture->size tags)
|
|
(let ((p (tags-picture tags)))
|
|
(if (eq? p #f) #f (id3-picture-size p))))
|
|
|
|
(define (tags-picture->file tags path)
|
|
(let ((p (tags-picture tags)))
|
|
(if (eq? p #f)
|
|
#f
|
|
(let* ((in (open-input-bytes (id3-picture-bytes p)))
|
|
(fh (open-output-file path #:mode 'binary #:exists 'replace)))
|
|
(let ((bytes (read-bytes 16384 in)))
|
|
(while (and (not (eof-object? bytes)) (> (bytes-length bytes) 0))
|
|
(write-bytes bytes fh)
|
|
(set! bytes (read-bytes 16384 in))))
|
|
(close-output-port fh)
|
|
(close-input-port in)
|
|
#t))))
|
|
|
|
)
|