78 lines
2.1 KiB
Racket
78 lines
2.1 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/winapi
|
|
ffi/unsafe/custodian
|
|
ffi/unsafe/atomic
|
|
racket/class
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt")
|
|
|
|
(provide
|
|
(protect-out play-sound))
|
|
|
|
(define BUFFER-SIZE 512)
|
|
(define BUFFER-BYTES-SIZE (* 2 BUFFER-SIZE))
|
|
|
|
(define-winmm mciGetErrorStringW
|
|
(_fun _int
|
|
[buf : _pointer = (malloc BUFFER-BYTES-SIZE)]
|
|
[_int = BUFFER-SIZE]
|
|
-> [ret : _bool]
|
|
-> (and ret (cast buf _pointer _string/utf-16))))
|
|
|
|
(define-winmm mciSendStringW
|
|
(_fun _string/utf-16 [_pointer = #f] [_int = 0] [_pointer = #f]
|
|
-> [ret : _int]
|
|
-> (if (zero? ret)
|
|
(void)
|
|
(error 'mciSendStringW "~a" (mciGetErrorStringW ret)))))
|
|
|
|
(define (mci-send fmt . args)
|
|
(mciSendStringW (apply format fmt args)))
|
|
|
|
(define-winmm mciSendStringW*
|
|
(_fun _string/utf-16
|
|
[buf : _pointer = (malloc BUFFER-BYTES-SIZE)]
|
|
[_int = BUFFER-SIZE]
|
|
[_pointer = #f]
|
|
-> [ret : _int]
|
|
-> (if (zero? ret)
|
|
(cast buf _pointer _string/utf-16)
|
|
(error 'mciSendStringW* "~a" (mciGetErrorStringW ret))))
|
|
#:c-id mciSendStringW)
|
|
|
|
(define (mci-send* fmt . args)
|
|
(mciSendStringW* (apply format fmt args)))
|
|
|
|
(define (play-sound file async?)
|
|
;; Generated ID is unique enough, because we only
|
|
;; instantiate this library in one place:
|
|
(define id (gensym 'play))
|
|
(define cust (make-custodian))
|
|
(call-as-atomic
|
|
(lambda ()
|
|
(mci-send "open \"~a\" alias ~a" (simplify-path file) id)
|
|
(register-custodian-shutdown
|
|
id
|
|
(lambda (id)
|
|
(mci-send "close ~a" id))
|
|
cust)))
|
|
(define (done msec)
|
|
(when msec (sleep (/ msec 1000)))
|
|
(custodian-shutdown-all cust))
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(mci-send "set ~a time format milliseconds" id)
|
|
(define len (let ([s (mci-send* "status ~a length" id)])
|
|
(string->number s)))
|
|
(unless len (error 'play "mci did not return a numeric length"))
|
|
(mci-send "play ~a" id)
|
|
(if async? (thread (lambda () (done len))) (done len)))
|
|
(lambda ()
|
|
(unless async?
|
|
(done #f))))
|
|
;; Report success, since otherwise we throw an error:
|
|
#t)
|