From 4b6adc404e01807f680bc3951b6a6408001bf95b Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Sun, 7 Jun 2026 23:49:38 +0200 Subject: [PATCH] xiph opusfile support and taglib write support. --- audio-placed-player.rkt | 35 +++ audio-player.rkt | 14 +- opusfile-decoder.rkt | 34 ++- play-test.rkt | 4 +- taglib-ffi.rkt | 234 +++++++++------- taglib-tests.rkt | 278 ++++++++++++++++++ taglib.rkt | 607 +++++++++++++++++++++++++++------------- tests.rkt | 2 +- 8 files changed, 905 insertions(+), 303 deletions(-) create mode 100644 taglib-tests.rkt diff --git a/audio-placed-player.rkt b/audio-placed-player.rkt index bb8306a..5889ae7 100644 --- a/audio-placed-player.rkt +++ b/audio-placed-player.rkt @@ -337,6 +337,32 @@ (audio-read-worker ao-dec current-file-id) current-file-id) + (define (param! par val) + (cond + ((eq? par 'opus-bits) + (if (integer? val) + (cond + ((= val 16) + (current-opusfile-output-format 's16) + 16 + ) + ((= val 24) + (current-opusfile-output-format 's24) + 24) + (else 'error-unsupported-value) + ) + 'error-wrong-value-type) + ) + (else 'error-unknown-param))) + + (define (param par) + (cond + ((eq? par 'opus-bits) + (if (eq? (current-opusfile-output-format) 's16) + 16 + 24)) + (else 'error-unknown-param))) + (define (pause paused) (when (or (eq? player-state 'paused) (eq? player-state 'playing)) @@ -478,6 +504,15 @@ (do-rpc (stop-and-cleanup) '(ok))) + ((eq? cmd 'param!) + (do-rpc + (let ((par (cadr data)) + (value (caddr data))) + (list (param! par value))))) + ((eq? cmd 'param) + (do-rpc + (let ((par (cadr data))) + (list (param par))))) ((eq? cmd 'state) (do-rpc (let ((st #f)) diff --git a/audio-player.rkt b/audio-player.rkt index fd07437..f7c9a0d 100644 --- a/audio-player.rkt +++ b/audio-player.rkt @@ -33,6 +33,8 @@ audio-ao-buf-ms! audio-ao-buf-ms audio-known-exts? + audio-param! + audio-param ) (define-runtime-path placed-player-module "audio-placed-player.rkt") @@ -52,6 +54,9 @@ (define (percentage? p) (and (number? p) (>= p 0))) +(define (any? x) + #t) + (define (max-percentage? n) (λ (p) (and (percentage? p) (<= p n)))) @@ -280,7 +285,14 @@ (define/contract (audio-ao-buf-ms handle) (-> audio-play? (or/c integer? boolean?)) ((audio-play-rpc handle) 'ao-buf-ms)) - + +(define/contract (audio-param! handle param value) + (-> audio-play? symbol? any? any?) + ((audio-play-rpc handle) 'param! param value)) + +(define/contract (audio-param handle param) + (-> audio-play? symbol? any?) + ((audio-play-rpc handle) 'param param)) diff --git a/opusfile-decoder.rkt b/opusfile-decoder.rkt index 4c5c71c..435339b 100644 --- a/opusfile-decoder.rkt +++ b/opusfile-decoder.rkt @@ -24,9 +24,21 @@ ;; Opus decode output is always 48 kHz PCM. The original input rate, if ;; present in metadata, is not the actual decoder output rate. - (define libopusfile - (with-handlers ([exn:fail? (lambda (_) #f)]) - (ffi-lib "libopusfile" '("0" #f)))) + + (define libogg (get-lib (case (system-type 'os) + [(windows) '("ogg")] + [else '("ogg" "libogg")]) + '(#f))) + + (define libopus (get-lib (case (system-type 'os) + [(windows) '("opus")] + [else '("opus" "libopus")]) + '(#f))) + + (define libopusfile (get-lib (case (system-type 'os) + [(windows) '("opusfile")] + [else '("opusfile" "libopusfile")]) + '(#f))) (define _OggOpusFile _pointer) @@ -36,12 +48,16 @@ (define (opusfile-output-format? v) (or (eq? v 's16) (eq? v 's24))) - (define current-opusfile-output-format - (make-parameter 's16 - (lambda (v) - (unless (opusfile-output-format? v) - (raise-argument-error 'current-opusfile-output-format "(or/c 's16 's24)" v)) - v))) + (define cur-output-format 's16) + + (define (current-opusfile-output-format . args) + (unless (null? args) + (if (or (> (length args) 1) + (not (opusfile-output-format? (car args)))) + (raise-argument-error 'current-opusfile-output-format + "(or/c 's16 's24)") + (set! cur-output-format (car args)))) + cur-output-format) (define (opus-bits-per-sample) (case (current-opusfile-output-format) diff --git a/play-test.rkt b/play-test.rkt index 1cf6e91..6b18381 100644 --- a/play-test.rkt +++ b/play-test.rkt @@ -9,7 +9,7 @@ "tests.rkt" ) -(define place-mode #f) +(define place-mode #t) (define run-queue #f) (define (set-test a) @@ -26,7 +26,7 @@ ) (sprintf "%02d:%02d" minutes seconds))) -(define (audio-player-state h st) +(define (audio-player-state h s st) (early-return ((? (not (audio-play? h)) => 'done)) (let* ((f (audio-file h)) diff --git a/taglib-ffi.rkt b/taglib-ffi.rkt index 0e80a44..0605b0a 100644 --- a/taglib-ffi.rkt +++ b/taglib-ffi.rkt @@ -3,8 +3,7 @@ (require ffi/unsafe ffi/unsafe/define "private/utils.rkt" - "private/downloader.rkt" - ) + "private/downloader.rkt") (provide TagLib_File_Type _TagLib_File-pointer @@ -16,11 +15,12 @@ taglib_file_new_type taglib_file_is_valid taglib_file_free + taglib_file_save taglib_file_tag taglib_file_audioproperties taglib_tag_free_strings - + taglib_tag_title taglib_tag_artist taglib_tag_album @@ -29,6 +29,14 @@ taglib_tag_year taglib_tag_track + taglib_tag_set_title + taglib_tag_set_artist + taglib_tag_set_album + taglib_tag_set_comment + taglib_tag_set_genre + taglib_tag_set_year + taglib_tag_set_track + taglib_audioproperties_length taglib_audioproperties_bitrate taglib_audioproperties_samplerate @@ -36,36 +44,19 @@ taglib_property_keys taglib_property_key - taglib_property_get taglib_property_val - + taglib_property_set + taglib_property_set_append taglib_property_free + taglib_complex_property_set + taglib_complex_property_set_append + taglib-get-picture - ) - - -;(define-runtime-path lib-path ".."); -; -;(define libs (let ((os-type (system-type 'os*))) -; (if (eq? os-type 'windows) -; (list -; (build-path lib-path "lib" "dll" "tag") -; (build-path lib-path "lib" "dll" "tag_c")) -; (let* ((arch (symbol->string (system-type 'arch))) -; (subdir (string-append (symbol->string os-type) "-" arch))) -; (list -; (build-path lib-path "lib" subdir "libtag") -; (build-path lib-path "lib" subdir "libtag_c")))))) - -;(define (get-lib l) -; (ffi-lib l '("2" #f) -; #:get-lib-dirs (λ () -; (cons (build-path ".") (get-lib-search-dirs))) -; #:fail (λ () -; (error (format "Cannot find library ~a" l))) -; )) + taglib-set-picture + taglib-append-picture + taglib-clear-picture) (define zlib (get-lib '("zlib" "libz") '(#f))) (define libtag (get-lib '("tag" "libtag") '("2" #f))) @@ -97,45 +88,39 @@ dsf dsdiff shorten - ))) + matroska))) (define _TagLib_File-pointer (_cpointer/null 'taglib-file)) (define _TagLib_Tag-pointer (_cpointer/null 'taglib-tag)) (define _TagLib_AudioProperties-pointer (_cpointer/null 'taglib-audioproperties)) -; TagLib_File *taglib_file_new(const char *filename); (define-tag-c-lib taglib_file_new - (_fun _string/utf-8 -> _TagLib_File-pointer )) + (_fun _string/utf-8 -> _TagLib_File-pointer)) -; TAGLIB_C_EXPORT TagLib_File *taglib_file_new_wchar(const wchar_t *filename); (define-tag-c-lib taglib_file_new_wchar - (_fun _string/utf-16 -> _TagLib_File-pointer )) + (_fun _string/utf-16 -> _TagLib_File-pointer)) -; TagLib_File *taglib_file_new_type(const char *filename, TagLib_File_Type type); (define-tag-c-lib taglib_file_new_type (_fun _string/utf-8 TagLib_File_Type -> _TagLib_File-pointer)) -; TagLib_File *taglib_file_new_type_wchar(const char *filename, TagLib_File_Type type); (define-tag-c-lib taglib_file_new_type_wchar (_fun _string/utf-16 TagLib_File_Type -> _TagLib_File-pointer)) -; void taglib_file_free(TagLib_File *file); (define-tag-c-lib taglib_file_free (_fun _TagLib_File-pointer -> _void)) -; BOOL taglib_file_is_valid(const TagLib_File *file); (define-tag-c-lib taglib_file_is_valid (_fun _TagLib_File-pointer -> _bool)) -; TagLib_Tag *taglib_file_tag(const TagLib_File *file); +(define-tag-c-lib taglib_file_save + (_fun _TagLib_File-pointer -> _bool)) + (define-tag-c-lib taglib_file_tag (_fun _TagLib_File-pointer -> _TagLib_Tag-pointer)) -; const TagLib_AudioProperties *taglib_file_audioproperties(const TagLib_File *file); (define-tag-c-lib taglib_file_audioproperties (_fun _TagLib_File-pointer -> _TagLib_AudioProperties-pointer)) -; void taglib_tag_free_strings(void); (define-tag-c-lib taglib_tag_free_strings (_fun -> _void)) @@ -150,12 +135,8 @@ (_fun _TagLib_Tag-pointer -> _string/utf-8))) ((_ name ret-type) (define-tag-c-lib name - (_fun _TagLib_Tag-pointer -> ret-type))) - )) + (_fun _TagLib_Tag-pointer -> ret-type))))) - -; char *taglib_tag_title(const TagLib_Tag *tag); -; etc.. (tg taglib_tag_title) (tg taglib_tag_artist) (tg taglib_tag_album) @@ -164,6 +145,23 @@ (tg taglib_tag_year _uint) (tg taglib_tag_track _uint) +(define-syntax tgs + (syntax-rules () + ((_ name) + (define-tag-c-lib name + (_fun _TagLib_Tag-pointer _string/utf-8 -> _void))) + ((_ name arg-type) + (define-tag-c-lib name + (_fun _TagLib_Tag-pointer arg-type -> _void))))) + +(tgs taglib_tag_set_title) +(tgs taglib_tag_set_artist) +(tgs taglib_tag_set_album) +(tgs taglib_tag_set_comment) +(tgs taglib_tag_set_genre) +(tgs taglib_tag_set_year _uint) +(tgs taglib_tag_set_track _uint) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; audio properties ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -172,11 +170,7 @@ (syntax-rules () ((_ name) (define-tag-c-lib name - (_fun _TagLib_AudioProperties-pointer -> _int))) - )) - -; int taglib_audioproperties_length(const TagLib_AudioProperties *audioProperties); -; etc... + (_fun _TagLib_AudioProperties-pointer -> _int))))) (ap taglib_audioproperties_length) (ap taglib_audioproperties_bitrate) @@ -184,24 +178,29 @@ (ap taglib_audioproperties_channels) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; keys in the propertymap +;; property map ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; char** taglib_property_keys(const TagLib_File *file); (define-tag-c-lib taglib_property_keys (_fun _TagLib_File-pointer -> (_ptr i _string/utf-8))) (define (taglib_property_key keys i) (ptr-ref keys _string/utf-8 i)) -;char** taglib_property_get(const TagLib_File *file, const char *prop); (define-tag-c-lib taglib_property_get (_fun _TagLib_File-pointer _string/utf-8 -> (_ptr i _string/utf-8))) (define (taglib_property_val prop i) (ptr-ref prop _string/utf-8 i)) -; void taglib_property_free(char **props); +;; value may be NULL to clear the property. +(define-tag-c-lib taglib_property_set + (_fun _TagLib_File-pointer _string/utf-8 _pointer -> _void)) + +;; value may be NULL to clear all values for the property. +(define-tag-c-lib taglib_property_set_append + (_fun _TagLib_File-pointer _string/utf-8 _pointer -> _void)) + (define-tag-c-lib taglib_property_free (_fun _pointer -> _void)) @@ -209,40 +208,12 @@ ;; Picture data ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;typedef struct { -; char *mimeType; -; char *description; -; char *pictureType; -; char *data; -; unsigned int size; -;} TagLib_Complex_Property_Picture_Data; - (define-cstruct _TagLib_Complex_Property_Picture_Data - ( - [mimeType _string/utf-8] + ([mimeType _string/utf-8] [description _string/utf-8] [pictureType _string/utf-8] [data _pointer] - [size _uint] - )) - - - -; TagLib_Complex_Property_Attribute*** properties = * taglib_complex_property_get(file, "PICTURE"); -; * TagLib_File *file = taglib_file_new("myfile.mp3"); -; * TagLib_Complex_Property_Attribute*** properties = -; * taglib_complex_property_get(file, "PICTURE"); -; * TagLib_Complex_Property_Picture_Data picture; -; * taglib_picture_from_complex_property(properties, &picture); -; * // Do something with picture.mimeType, picture.description, -; * // picture.pictureType, picture.data, picture.size, e.g. extract it. -; * FILE *fh = fopen("mypicture.jpg", "wb"); -; * if(fh) { -; * fwrite(picture.data, picture.size, 1, fh); -; * fclose(fh); -; * } -; * taglib_complex_property_free(properties); + [size _uint])) (define _Complex_Property_Attribute-pointer (_cpointer/null 'taglib-complex-property-attribute)) @@ -257,38 +228,97 @@ (define-tag-c-lib taglib_complex_property_free (_fun _Complex_Property_Attribute-pointer -> _void)) -;TAGLIB_C_EXPORT char** taglib_complex_property_keys(const TagLib_File *file); (define-tag-c-lib taglib_complex_property_keys (_fun _TagLib_File-pointer -> (_ptr i _string/utf-8))) -; void taglib_complex_property_free_keys(char **keys); (define-tag-c-lib taglib_complex_property_free_keys (_fun _pointer -> _void)) +;; TagLib_Variant is { enum type; unsigned int size; union value; }. +;; For writing pictures we only use pointer-valued union members: stringValue +;; and byteVectorValue. A pointer-sized field has the same size/alignment as +;; the union on the supported ABIs. +(define TagLib_Variant_ByteVector 9) +(define TagLib_Variant_String 7) + +(define-cstruct _TagLib_Variant + ([type _int] + [size _uint] + [value _pointer])) + +(define-cstruct _TagLib_Complex_Property_Attribute + ([key _pointer] + [value _TagLib_Variant])) + +(define-tag-c-lib taglib_complex_property_set + (_fun _TagLib_File-pointer _string/utf-8 _pointer -> _bool)) + +(define-tag-c-lib taglib_complex_property_set_append + (_fun _TagLib_File-pointer _string/utf-8 _pointer -> _bool)) + +(define (bytes->malloc-ptr bs [nul? #f]) + (define len (bytes-length bs)) + (define ptr (malloc _byte (+ len (if nul? 1 0)) 'atomic-interior)) + (for ([i (in-range len)]) (ptr-set! ptr _byte i (bytes-ref bs i))) + (when nul? (ptr-set! ptr _byte len 0)) + ptr) + +(define (string->malloc-cstring s) + (bytes->malloc-ptr (string->bytes/utf-8 s) #t)) + +(define (picture->complex-property data size description mimetype picture-type) + (define data-ptr (bytes->malloc-ptr data #f)) + (define data-key (string->malloc-cstring "data")) + (define mime-key (string->malloc-cstring "mimeType")) + (define desc-key (string->malloc-cstring "description")) + (define type-key (string->malloc-cstring "pictureType")) + (define mime-ptr (string->malloc-cstring mimetype)) + (define desc-ptr (string->malloc-cstring description)) + (define type-ptr (string->malloc-cstring picture-type)) + (define data-attr (make-TagLib_Complex_Property_Attribute data-key (make-TagLib_Variant TagLib_Variant_ByteVector size data-ptr))) + (define mime-attr (make-TagLib_Complex_Property_Attribute mime-key (make-TagLib_Variant TagLib_Variant_String 0 mime-ptr))) + (define desc-attr (make-TagLib_Complex_Property_Attribute desc-key (make-TagLib_Variant TagLib_Variant_String 0 desc-ptr))) + (define type-attr (make-TagLib_Complex_Property_Attribute type-key (make-TagLib_Variant TagLib_Variant_String 0 type-ptr))) + (define propv (malloc _pointer 5 'atomic-interior)) + (ptr-set! propv _pointer 0 data-attr) + (ptr-set! propv _pointer 1 mime-attr) + (ptr-set! propv _pointer 2 desc-attr) + (ptr-set! propv _pointer 3 type-attr) + (ptr-set! propv _pointer 4 #f) + ;; Return keepalive values as well as the pointer array. TagLib copies during + ;; taglib_complex_property_set(), but all buffers must remain live for the call. + (values propv (list data-ptr data-key mime-key desc-key type-key mime-ptr desc-ptr type-ptr + data-attr mime-attr desc-attr type-attr propv))) + +(define (taglib-set-picture tag-file mimetype picture-type description data) + (define-values (props keepalive) + (picture->complex-property data (bytes-length data) description mimetype picture-type)) + (define ok? (taglib_complex_property_set tag-file "PICTURE" props)) + keepalive + ok?) + +(define (taglib-append-picture tag-file mimetype picture-type description data) + (define-values (props keepalive) + (picture->complex-property data (bytes-length data) description mimetype picture-type)) + (define ok? (taglib_complex_property_set_append tag-file "PICTURE" props)) + keepalive + ok?) + +(define (taglib-clear-picture tag-file) + (taglib_complex_property_set tag-file "PICTURE" #f)) + (define (taglib-get-picture tag-file) - (define (cp s) (string-append s "")) - (define (to-bytestring data size) - - (let* ((v (make-vector size 0)) - (i 0)) - (while (< i size) - (vector-set! v (ptr-ref data _byte i) i) - (set! i (+ i 1))) - v)) + (define (cp s) (if (eq? s #f) "" (string-append s ""))) (let ((props (taglib_complex_property_get tag-file "PICTURE"))) (if (eq? props #f) #f (let ((pd (make-TagLib_Complex_Property_Picture_Data #f #f #f #f 0))) (taglib_picture_from_complex_property props pd) (let* ((mimetype (cp (TagLib_Complex_Property_Picture_Data-mimeType pd))) - (description (cp (TagLib_Complex_Property_Picture_Data-description pd))) + (description (cp (TagLib_Complex_Property_Picture_Data-description pd))) (type (cp (TagLib_Complex_Property_Picture_Data-pictureType pd))) (size (TagLib_Complex_Property_Picture_Data-size pd)) - (data (cast (TagLib_Complex_Property_Picture_Data-data pd) - _pointer - (_bytes o size))) - ) + (data (cast (TagLib_Complex_Property_Picture_Data-data pd) _pointer (_bytes o size)))) (let ((r (list mimetype description type size data))) (taglib_complex_property_free props) - r)))) - )) \ No newline at end of file + r)))))) diff --git a/taglib-tests.rkt b/taglib-tests.rkt new file mode 100644 index 0000000..6d27800 --- /dev/null +++ b/taglib-tests.rkt @@ -0,0 +1,278 @@ +#lang racket/base + +(require rackunit + racket/class + racket/draw + racket/file + racket/list + racket/path + racket/runtime-path + "taglib.rkt") + +(provide run-taglib-tests + run-taglib-tests/verbose + current-taglib-test-verbosity + test-audio-dir + taglib-read-files + taglib-write-files) + +;; These tests expect the repository hans/racket-audio-test next to this +;; package checkout, matching the layout already used by tests.rkt: +;; +;; parent/ +;; racket-audio/ +;; racket-audio-test/ +;; +;; The tests are defensive: missing test files are skipped, but existing files +;; are tested. Write tests always work on a temporary copy and never modify the +;; original test audio files. + + +(define current-taglib-test-verbosity (make-parameter 'normal)) + +(define (taglib-test-verbose?) + (memq (current-taglib-test-verbosity) '(verbose very-verbose))) + +(define (taglib-test-note fmt . args) + (when (taglib-test-verbose?) + (apply printf fmt args) + (newline) + (flush-output))) + +(define-syntax-rule (taglib-test-case name body ...) + (test-case name + (taglib-test-note "[taglib] running: ~a" name) + body ... + (taglib-test-note "[taglib] ok: ~a" name))) + +(define-runtime-path test-audio-dir "../racket-audio-test") + +(define taglib-read-files + '("idyll.flac" + "idyll.m4a" + "idyll.mp3" + "idyll.ogg" + "idyll.opus" + "mahler-1.mp3" + "mahler-1.ogg" + "mahler-1.opus" + "mahler-2.mp3" + "mahler-2.ogg" + "mahler-2.opus" + "ff-16b-2c-44100hz.flac" + "ff-16b-2c-44100hz.m4a" + "ff-16b-2c-44100hz.mp3" + "ff-16b-2c-44100hz.ogg" + "ff-16b-2c-44100hz.opus")) + +;; Keep the write matrix deliberately small. These formats should cover the +;; main TagLib backends used by the package without making the test suite slow. +(define taglib-write-files + '("idyll.flac" + "idyll.mp3" + "idyll.m4a" + "idyll.ogg" + "idyll.opus")) + +(define (existing-test-files names) + (for/list ([name (in-list names)] + #:when (file-exists? (build-path test-audio-dir name))) + (build-path test-audio-dir name))) + +(define (taglib-usable?) + (with-handlers ([exn:fail? (lambda (_) #f)]) + (define files (existing-test-files taglib-read-files)) + (and (pair? files) + (let ([tags (id3-tags (car files))]) + (and (tags-valid? tags) #t))))) + +(define (copy-test-file-to-temp src) + (define dst (make-temporary-file (format "racket-audio-taglib-~a-~~a~a" + (path->string (file-name-from-path src)) + (or (path-get-extension src) #"")))) + (copy-file src dst #t) + dst) + +(define (check-nonnegative/name name v) + (check-true (and (exact-integer? v) (>= v -1)) name)) + +(define (check-readable-snapshot path) + (taglib-test-case (format "read-only snapshot: ~a" (file-name-from-path path)) + (define tags (id3-tags path)) + (check-true (tags-valid? tags)) + (check-false (tags-read-write? tags)) + (check-true (tags-closed? tags)) + (check-pred string? (tags-title tags)) + (check-pred string? (tags-album tags)) + (check-pred string? (tags-artist tags)) + (check-pred string? (tags-comment tags)) + (check-pred string? (tags-genre tags)) + (check-nonnegative/name "year" (tags-year tags)) + (check-nonnegative/name "track" (tags-track tags)) + (check-nonnegative/name "length" (tags-length tags)) + (check-nonnegative/name "sample-rate" (tags-sample-rate tags)) + (check-nonnegative/name "bit-rate" (tags-bit-rate tags)) + (check-nonnegative/name "channels" (tags-channels tags)) + (check-true (list? (tags-keys tags))) + ;; A read-only snapshot must still be usable after the native TagLib file + ;; has been closed. This protects the audio playback path from stale file + ;; handles/locks after metadata reading. + (check-pred hash? (tags->hash tags)) + (check-exn exn:fail? (lambda () (tags-title! tags "must fail"))))) + +(define (check-call-with-closes path) + (taglib-test-case (format "call-with-id3-tags closes read-write handle: ~a" (file-name-from-path path)) + (define captured #f) + (with-handlers ([exn:fail? void]) + (call-with-id3-tags path #:mode 'read-write + (lambda (tags) + (set! captured tags) + (check-true (tags-read-write? tags)) + (check-false (tags-closed? tags)) + (error 'expected-test-exception "force close path")))) + (check-true (tags-closed? captured)))) + +(define (check-simple-write-roundtrip path) + (taglib-test-case (format "tag write/read/clear roundtrip: ~a" (file-name-from-path path)) + (define tmp (copy-test-file-to-temp path)) + (displayln (format "tmp = ~a" tmp)) + (dynamic-wind + void + (lambda () + (define title (format "Racket Audio TagLib Test ~a" (current-inexact-milliseconds))) + (call-with-id3-tags tmp #:mode 'read-write + (lambda (tags) + (check-true (tags-valid? tags)) + (check-true (tags-read-write? tags)) + (check-false (tags-closed? tags)) + (tags-title! tags title) + (tags-album! tags "Racket Audio Test Album") + (tags-artist! tags "Racket Audio Test Artist") + (tags-comment! tags "Written by racket-audio taglib-tests.rkt") + (tags-genre! tags "Test") + (tags-year! tags 2026) + (tags-track! tags 7) + (tags-composer! tags "Racket Composer") + (tags-album-artist! tags "Racket Album Artist") + (tags-disc-number! tags 2) + (tags-set-values! tags 'performer '("Performer One" "Performer Two")) + (check-true (tags-save! tags)))) + + (define reread (id3-tags tmp)) + (check-true (tags-valid? reread)) + (check-true (tags-closed? reread)) + (check-equal? (tags-title reread) title) + (check-equal? (tags-album reread) "Racket Audio Test Album") + (check-equal? (tags-artist reread) "Racket Audio Test Artist") + (check-equal? (tags-comment reread) "Written by racket-audio taglib-tests.rkt") + (check-equal? (tags-genre reread) "Test") + (check-equal? (tags-year reread) 2026) + (check-equal? (tags-track reread) 7) + (check-equal? (tags-composer reread) "Racket Composer") + (check-equal? (tags-album-artist reread) "Racket Album Artist") + (check-equal? (tags-disc-number reread) 2) + (check-equal? (tags-ref reread 'performer) '("Performer One" "Performer Two")) + + (call-with-id3-tags tmp #:mode 'read-write + (lambda (tags) + (tags-title! tags 'clear) + (tags-year! tags 'clear) + (tags-track! tags 'clear) + (tags-clear! tags 'composer) + (tags-clear! tags 'performer) + (check-true (tags-save! tags)))) + + (define cleared (id3-tags tmp)) + (check-equal? (tags-title cleared) "") + (check-equal? (tags-year cleared) -1) + (check-equal? (tags-track cleared) -1) + (check-equal? (tags-composer cleared) "") + (check-false (tags-ref cleared 'performer))) + (lambda () + (when (file-exists? tmp) (delete-file tmp)))))) + +(define (make-test-bitmap) + (define bm (make-object bitmap% 4 4)) + (define dc (new bitmap-dc% [bitmap bm])) + (send dc set-pen "black" 1 'solid) + (send dc set-brush "white" 'solid) + (send dc draw-rectangle 0 0 4 4) + (send dc set-pen "black" 1 'solid) + (send dc draw-line 0 0 3 3) + (send dc set-bitmap #f) + bm) + +(define (check-picture-roundtrip path) + (taglib-test-case (format "picture write/read/clear roundtrip: ~a" (file-name-from-path path)) + (define tmp (copy-test-file-to-temp path)) + (dynamic-wind + void + (lambda () + (define picture (make-tags-picture-from-bitmap (make-test-bitmap) + "Front Cover" + #:mimetype "image/png" + #:description "Racket test cover")) + (call-with-id3-tags tmp #:mode 'read-write + (lambda (tags) + (tags-picture! tags picture) + (check-true (tags-save! tags)))) + + (define reread (id3-tags tmp)) + (define p (tags-picture reread)) + (check-true (id3-picture? p)) + (check-equal? (id3-picture-mimetype p) "image/png") + (check-equal? (id3-picture-kind p) "Front Cover") + (check-equal? (id3-picture-description p) "Racket test cover") + (check-true (> (id3-picture-size p) 0)) + (check-true (is-a? (tags-picture->bitmap reread) bitmap%)) + + (call-with-id3-tags tmp #:mode 'read-write + (lambda (tags) + (tags-clear-picture! tags) + (check-true (tags-save! tags)))) + (check-false (tags-picture (id3-tags tmp))) + ) + (lambda () + (when (file-exists? tmp) (delete-file tmp)))))) + +(define (run-taglib-tests [verbosity 'normal]) + (unless (memq verbosity '(quiet normal verbose very-verbose)) + (raise-argument-error 'run-taglib-tests "(or/c 'quiet 'normal 'verbose 'very-verbose)" verbosity)) + (parameterize ([current-taglib-test-verbosity verbosity]) + (cond + [(not (directory-exists? test-audio-dir)) + (unless (eq? verbosity 'quiet) + (printf "Skipping TagLib tests: test audio directory not found: ~a\n" test-audio-dir)) + (void)] + [(not (taglib-usable?)) + (unless (eq? verbosity 'quiet) + (printf "Skipping TagLib tests: TagLib runtime is not available or no readable test file was found.\n")) + (void)] + [else + (define read-files (existing-test-files taglib-read-files)) + (define write-files (existing-test-files taglib-write-files)) + (taglib-test-note "[taglib] test audio directory: ~a" test-audio-dir) + (taglib-test-note "[taglib] read files: ~a" (length read-files)) + (taglib-test-note "[taglib] write files: ~a" (length write-files)) + (for ([path (in-list read-files)]) (check-readable-snapshot path)) + (when (pair? write-files) + ;; call-with close behavior only needs one writable copy. + (define tmp (copy-test-file-to-temp (car write-files))) + (dynamic-wind void + (lambda () (check-call-with-closes tmp)) + (lambda () (when (file-exists? tmp) (delete-file tmp))))) + (for ([path (in-list write-files)]) (check-simple-write-roundtrip path)) + ;; Exercise picture writing on FLAC first, because it is the least + ;; ambiguous container for embedded cover-art roundtrips with TagLib. + (define flac (build-path test-audio-dir "idyll.flac")) + (when (file-exists? flac) (check-picture-roundtrip flac)) + (taglib-test-note "[taglib] done")]))) + +(define (run-taglib-tests/verbose) + (run-taglib-tests 'verbose)) + +(module+ test + (run-taglib-tests)) + +(module+ main + (run-taglib-tests)) diff --git a/taglib.rkt b/taglib.rkt index f2f52d2..7516125 100644 --- a/taglib.rkt +++ b/taglib.rkt @@ -2,12 +2,19 @@ (require "taglib-ffi.rkt" "private/utils.rkt" - racket/string - racket/draw) + 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 @@ -19,7 +26,18 @@ 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 @@ -27,202 +45,407 @@ 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-tag-struct (handle)) + (define-struct id3-picture (mimetype kind size bytes description)) - (define-struct id3-picture - (mimetype kind size bytes)) + (define clear-tag-value 'clear) - (define (id3-tags file*) - (let ((file (if (path? file*) (path->string file*) file*)) - (valid? #f) - (title "") - (album "") - (artist "") - (comment "") - (year -1) - (genre "") - (track -1) - (length -1) - (sample-rate -1) - (bit-rate -1) - (channels -1) - (key-store (make-hash)) - (composer "") - (album-artist "") - (disc-number -1) - (picture #f)) - (let ((tag-file (taglib_file_new file))) - (if (eq? tag-file #f) + (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) - (set! valid? (taglib_file_is_valid tag-file))) - - (unless valid? - (when (eq? (system-type 'os) 'windows) - (dbg-sound "Could not open file ~a, trying wchar version on windows" file) - (unless (eq? tag-file #f) - (taglib_file_free tag-file)) - (set! tag-file (taglib_file_new_wchar file)) - (if (eq? tag-file #f) - (set! valid? #f) - (set! valid? (taglib_file_is_valid tag-file))))) + (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!)))))) - (unless valid? - (warn-sound "Could not open file ~a" file) - (unless (eq? tag-file #f) - (taglib_file_free tag-file) - (set! tag-file #f))) - - (when valid? - (let ((tag (taglib_file_tag tag-file)) - (ap (taglib_file_audioproperties tag-file)) - (cp (lambda (s) (string-append s ""))) - ) - (set! title (cp (taglib_tag_title tag))) - (set! album (cp (taglib_tag_album tag))) - (set! artist (cp (taglib_tag_artist tag))) - (set! comment (cp (taglib_tag_comment tag))) - (set! genre (cp (taglib_tag_genre tag))) - (set! year (taglib_tag_year tag)) - (set! track (taglib_tag_track tag)) - - (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)) + (define (close!) + (unless closed? + (taglib_file_free tag-file) + (set! tag-file #f) + (set! tag #f) + (set! closed? #t)) + (void)) - (let* ((keys (taglib_property_keys tag-file)) - (i 0) - (key (taglib_property_key keys i)) - (key-list '()) - ) - (while (not (eq? key #f)) - (set! key-list (append key-list (list (cp 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 (taglib_property_val props i))) - (while (not (eq? val #f)) - (set! vals (append vals (list (cp val)))) - (set! i (+ i 1)) - (set! val (taglib_property_val props i))) - (taglib_property_free props) - (hash-set! key-store - (string->symbol - (string-downcase key)) vals) - ))) - key-list) - (set! composer (hash-ref key-store 'composer "")) - (set! album-artist (hash-ref key-store 'albumartist "")) - (set! disc-number (string->number - (car - (hash-ref key-store 'discnumber (list "-1"))))) - ) + (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))) - ; picture - (let ((p (taglib-get-picture tag-file))) - (if (eq? p #f) - (set! picture #f) - (let ((mimetype (car p)) - (kind (caddr p)) - (size (cadddr p)) - (bytes (car (cddddr p)))) - (set! picture (make-id3-picture mimetype kind size bytes)) - ))) + (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!)) - ; cleaning up - (taglib_tag_free_strings) - (taglib_file_free tag-file) - ) - ) - (let ((handle - (lambda (v . args) - (cond - [(eq? v 'valid?) valid?] - [(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 (car args) #f))] - [(eq? v 'picture) picture] - [(eq? v 'to-hash) - (let ((h (make-hash))) - (hash-set! h 'valid? valid?) - (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)] - [else (error (format "Unknown tag-cmd '~a'" v))] - )))) - (make-id3-tag-struct handle)) - ))) + (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))) - ))) + (apply (id3-tag-struct-handle tags) (cons v args)))))) (define-syntax defs (syntax-rules () - ((_ f1) - (def f1)) - ((_ f1 f2 ...) - (begin - (def f1) - (def f2) - ...)) - )) + ((_ 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) @@ -233,7 +456,18 @@ (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) @@ -241,10 +475,16 @@ (tags-keys 'keys) (tags-ref 'val) + (tags-set! 'set!) + (tags-set-values! 'set-values!) + (tags-append! 'append!) + (tags-clear! 'clear!) (tags-picture 'picture) - (tags->hash 'to-hash) - ) + (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))) @@ -257,34 +497,27 @@ (define (tags-picture->kind tags) (let ((p (tags-picture tags))) - (if (eq? p #f) - #f - (id3-picture-kind p)))) + (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)))) + (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) - ) - )) + [(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)))) + (if (eq? p #f) #f (id3-picture-size p)))) (define (tags-picture->file tags path) (let ((p (tags-picture tags))) @@ -299,7 +532,5 @@ (close-output-port fh) (close-input-port in) #t)))) - - - ); end of module + ) diff --git a/tests.rkt b/tests.rkt index d7c4f74..d6ca047 100644 --- a/tests.rkt +++ b/tests.rkt @@ -21,7 +21,7 @@ (define-runtime-path tests "../racket-audio-test") (define test-file1 (build-path tests "idyll.mp3")) -(define test-file2 (build-path tests "idyll.flac")) +(define test-file2 (build-path tests "idyll.opus")) (define test-file3 (build-path tests "mahler-1.mp3")) (define test-file4 (build-path tests "mahler-2.mp3")) (define test-file5 (build-path tests "mahler-1.opus"))