336 lines
11 KiB
Racket
336 lines
11 KiB
Racket
(module utils racket/base
|
|
|
|
(require racket/path
|
|
racket/file
|
|
racket/runtime-path
|
|
racket/system
|
|
ffi/unsafe
|
|
setup/dirs
|
|
"downloader.rkt"
|
|
simple-log
|
|
)
|
|
|
|
(provide while
|
|
until
|
|
build-lib-path
|
|
get-lib
|
|
get-lib/quiet
|
|
linux-lib-versions
|
|
ffmpeg-lib-versions
|
|
do-for
|
|
dbg-sound
|
|
info-sound
|
|
err-sound
|
|
warn-sound
|
|
fatal-sound
|
|
sync-log-sound
|
|
racket-sound-cache-directory
|
|
racket-sound-log-file
|
|
open-racket-sound-log-file
|
|
integer->int-bytes
|
|
int-bytes->integer
|
|
valid-ffmpeg-versions
|
|
make-mutex
|
|
mutex-lock
|
|
mutex-unlock
|
|
with-mutex
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Create log definitions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(sl-def-log racket-sound sound)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Standard cache/log paths
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (racket-sound-cache-directory)
|
|
(build-path (find-system-path 'cache-dir) "racket-audio"))
|
|
|
|
(define (racket-sound-log-file name)
|
|
(define filename
|
|
(cond [(symbol? name) (format "~a.log" name)]
|
|
[(string? name) name]
|
|
[else (raise-argument-error 'racket-sound-log-file "(or/c symbol? string?)" name)]))
|
|
(build-path (racket-sound-cache-directory) filename))
|
|
|
|
(define (open-racket-sound-log-file path #:exists [exists 'append])
|
|
(define parent (path-only (path->complete-path path)))
|
|
(when parent (make-directory* parent))
|
|
(open-output-file path #:exists exists))
|
|
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Mutex definitions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-struct mutex
|
|
(thread count mut own) #:mutable)
|
|
|
|
(define make-mutex-struct make-mutex)
|
|
|
|
(set! make-mutex (λ ()
|
|
(make-mutex-struct #f 0 (make-semaphore 1) (make-semaphore 1))))
|
|
|
|
(define (mutex-lock m)
|
|
(semaphore-wait (mutex-own m))
|
|
(if (eq? (mutex-thread m) (current-thread))
|
|
(begin
|
|
(set-mutex-count! m (+ (mutex-count m) 1))
|
|
(semaphore-post (mutex-own m))
|
|
)
|
|
(begin
|
|
(semaphore-post (mutex-own m))
|
|
(semaphore-wait (mutex-mut m))
|
|
(set-mutex-count! m 1)
|
|
(set-mutex-thread! m (current-thread)))
|
|
)
|
|
)
|
|
|
|
(define (mutex-unlock m)
|
|
(semaphore-wait (mutex-own m))
|
|
(let ((count (mutex-count m)))
|
|
(set! count (- count 1))
|
|
(set-mutex-count! m count)
|
|
(if (= count 0)
|
|
(begin
|
|
(set-mutex-thread! m #f)
|
|
(semaphore-post (mutex-own m))
|
|
(semaphore-post (mutex-mut m)))
|
|
(semaphore-post (mutex-own m)))
|
|
)
|
|
)
|
|
|
|
(define-syntax with-mutex
|
|
(syntax-rules ()
|
|
((_ m b1 ...)
|
|
(begin
|
|
(dynamic-wind
|
|
(λ () (mutex-lock m))
|
|
(λ () b1 ...)
|
|
(λ () (mutex-unlock m)))))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provide some loop constructions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax while
|
|
(syntax-rules ()
|
|
((_ cond body ...)
|
|
(letrec ((while-f (lambda (last-result)
|
|
(if cond
|
|
(let ((last-result (begin
|
|
body
|
|
...)))
|
|
(while-f last-result))
|
|
last-result))))
|
|
(while-f #f))
|
|
)
|
|
))
|
|
|
|
(define-syntax until
|
|
(syntax-rules ()
|
|
((_ cond body ...)
|
|
(letrec ((until-f (lambda (last-result)
|
|
(if cond
|
|
last-result
|
|
(let ((last-reult (begin
|
|
body
|
|
...)))
|
|
(until-f last-result))))))
|
|
(until-f #f)))))
|
|
|
|
(define-syntax do-for
|
|
(syntax-rules ()
|
|
((_ (init cond next) body ...)
|
|
(begin
|
|
init
|
|
(letrec ((do-for-f (lamba ()
|
|
(if cond
|
|
(begin
|
|
(begin
|
|
body
|
|
...)
|
|
next
|
|
(do-for-f))))))
|
|
(do-for-f))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Loading libraries
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define valid-ffmpeg-versions
|
|
(make-hash (list (list 'avutil 58 60 "libavutil")
|
|
(list 'avcodec 60 62 "libavcodec")
|
|
(list 'avformat 60 62 "libavformat")
|
|
(list 'swresample 4 6 "libswresample"))))
|
|
|
|
(define (versions-high-to-low from until)
|
|
(let loop ((n from) (acc '(#f)))
|
|
(if (> n until)
|
|
acc
|
|
(loop (+ n 1) (cons (number->string n) acc)))))
|
|
|
|
(define (ffmpeg-lib-versions kind)
|
|
(case (system-type 'os*)
|
|
[(linux)
|
|
(let ((v (hash-ref valid-ffmpeg-versions kind)))
|
|
(versions-high-to-low (car v) (cadr v)))]
|
|
[else '(#f)]))
|
|
|
|
(define (linux-lib-versions versions [default '(#f)])
|
|
(case (system-type 'os*)
|
|
[(linux) versions]
|
|
[else default]))
|
|
|
|
(define (ffmpeg-version-line kind)
|
|
(let ((v (hash-ref valid-ffmpeg-versions kind)))
|
|
(format " ~a: ~a .. ~a" (caddr v) (car v) (cadr v))))
|
|
|
|
(define (display-section title lines)
|
|
(displayln title)
|
|
(for ([line (in-list lines)]) (displayln line))
|
|
(newline))
|
|
|
|
(define (display-command title chunks)
|
|
(displayln title)
|
|
(displayln " sudo apt install \\")
|
|
(let loop ((xs chunks))
|
|
(cond [(null? xs) (newline)]
|
|
[(null? (cdr xs))
|
|
(displayln (format " ~a" (car xs)))
|
|
(newline)]
|
|
[else
|
|
(displayln (format " ~a \\" (car xs)))
|
|
(loop (cdr xs))])))
|
|
|
|
(define linux-runtime-package-lines
|
|
'("libflac12 libmpg123-0 libao4"
|
|
"libavcodec60 libavutil58 libswresample4 libavformat60"
|
|
"libogg0 libopus0 libopusenc0 libopusfile0"
|
|
"libsoxr0 libtag1v5"))
|
|
|
|
(define linux-dev-package-lines
|
|
'("libflac-dev libmpg123-dev libao-dev"
|
|
"libavcodec-dev libavutil-dev libswresample-dev libavformat-dev"
|
|
"libogg-dev libopus-dev libopusenc-dev libopusfile-dev"
|
|
"libsoxr-dev libtag1-dev"))
|
|
|
|
(define brew-package-lines
|
|
'("ffmpeg libao mpg123 flac opus"
|
|
"libopusenc libsoxr taglib"))
|
|
|
|
(define (lib-not-found-message orig-libs libs-path)
|
|
(newline)
|
|
(displayln "Warning: native library not found")
|
|
(newline)
|
|
(display-section "Tried library names:"
|
|
(for/list ([lib (in-list orig-libs)]) (format " - ~a" lib)))
|
|
(display-section "Search paths:"
|
|
(for/list ([path (in-list libs-path)]) (format " - ~a" path)))
|
|
(let ((st (system-type 'os*)))
|
|
(cond [(eq? st 'windows)
|
|
(display-section "Windows native library directory:"
|
|
(list (format " - ~a" (soundlibs-directory))))]
|
|
[(eq? st 'linux)
|
|
(display-command "Debian/Ubuntu runtime packages:" linux-runtime-package-lines)
|
|
(display-command "Debian/Ubuntu development packages, for local FFI rebuilding:" linux-dev-package-lines)]
|
|
[(eq? st 'macosx)
|
|
(display-command "Homebrew packages:" brew-package-lines)
|
|
(displayln "If your local setup uses ffmpeg-full instead of ffmpeg, install that variant instead.")
|
|
(newline)]
|
|
[else
|
|
(display-section "Required native libraries:"
|
|
'(" - xiph libao"
|
|
" - xiph libFLAC"
|
|
" - ffmpeg"
|
|
" - libmpg123"
|
|
" - libopus/libopusenc/libopusfile"
|
|
" - libsoxr"
|
|
" - taglib"))])
|
|
(display-section "Supported FFmpeg ABI versions:"
|
|
(list (ffmpeg-version-line 'avcodec)
|
|
(ffmpeg-version-line 'avutil)
|
|
(ffmpeg-version-line 'swresample)
|
|
(ffmpeg-version-line 'avformat)))))
|
|
|
|
(define (build-lib-path p)
|
|
(if (eq? (system-type 'os) 'macosx)
|
|
(let ((brew-lib "/opt/homebrew/lib"))
|
|
(cons (soundlibs-directory) (cons brew-lib p)))
|
|
(cons (soundlibs-directory) p)))
|
|
|
|
(define (get-lib* libs-to-try orig-libs versions warn?)
|
|
|
|
(unless (soundlibs-available?)
|
|
(download-soundlibs))
|
|
|
|
(let ((libs-path (build-lib-path (get-lib-search-dirs))))
|
|
(if (null? libs-to-try)
|
|
(begin
|
|
(when warn? (lib-not-found-message orig-libs libs-path))
|
|
#f)
|
|
(ffi-lib (car libs-to-try) versions
|
|
#:get-lib-dirs (λ () libs-path)
|
|
#:fail (λ ()
|
|
(ffi-lib (car libs-to-try) versions
|
|
#:fail (λ ()
|
|
(get-lib* (cdr libs-to-try) orig-libs versions warn?))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (get-lib libs-to-try versions)
|
|
(get-lib* libs-to-try libs-to-try versions #t))
|
|
|
|
(define (get-lib/quiet libs-to-try versions)
|
|
(get-lib* libs-to-try libs-to-try versions #f))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; integer->int-bytes and vise versa.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax-rule (integer->int-bytes v size signed? big? bs pos)
|
|
(if (= size 3)
|
|
(if big?
|
|
(begin
|
|
(bytes-set! bs pos (bitwise-and (arithmetic-shift v -16) #xff))
|
|
(bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8) #xff))
|
|
(bytes-set! bs (+ pos 2) (bitwise-and v #xff)))
|
|
(begin
|
|
(bytes-set! bs pos (bitwise-and v #xff))
|
|
(bytes-set! bs (+ pos 1) (bitwise-and (arithmetic-shift v -8) #xff))
|
|
(bytes-set! bs (+ pos 2) (bitwise-and (arithmetic-shift v -16) #xff))))
|
|
(integer->integer-bytes v size signed? big? bs pos)))
|
|
|
|
(define-syntax-rule (int-bytes->integer bs signed? big? start end)
|
|
(let ([size (- end start)])
|
|
(if (= size 3)
|
|
(let* ([b0 (bytes-ref bs start)]
|
|
[b1 (bytes-ref bs (+ start 1))]
|
|
[b2 (bytes-ref bs (+ start 2))]
|
|
[u (if big?
|
|
(bitwise-ior (arithmetic-shift b0 16)
|
|
(arithmetic-shift b1 8)
|
|
b2)
|
|
(bitwise-ior b0
|
|
(arithmetic-shift b1 8)
|
|
(arithmetic-shift b2 16)))])
|
|
(if (and signed? (not (zero? (bitwise-and u #x800000))))
|
|
(- u #x1000000)
|
|
u))
|
|
(integer-bytes->integer bs signed? big? start end))))
|
|
|
|
|
|
|
|
) ; end of module
|