Windows: change play-sound to use MCI

Provided by Eli Barzilay.

This approach is better than a separate process, because creating
too many processes can overwhelm the OS. Also, MCI supports more
sound formats.

gui-doc/scribblings/gui/miscwin-funcs.scrbl

@@ -322,7 +322,8 @@ Plays a sound file. If @racket[async?] is false, the function does not
  The result is @racket[#t] if the sound plays successfully, @racket[#f]
  otherwise.
 
-On Windows, only @filepath{.wav} files are supported.
+On Windows, MCI is used to play sounds, so file formats such as
+ @filepath{.wav} and @filepath{.mp3} should be supported.
 
 On Mac OS X, Quicktime is used to play sounds; most sound
  formats (@filepath{.wav}, @filepath{.aiff}, @filepath{.mp3}) are supported in recent versions of
@@ -341,7 +342,11 @@ On Unix, the function invokes an external sound-playing program---looking
   quotes.)  A plain command name is usually better, since execution is
   faster.  The command's output is discarded, unless it returns an
   error code, in which case the last part of the error output is
-  shown.}
+  shown.
+
+@history[#:changed "1.22" @elem{On Windows, added support for multiple
+                                sounds at once and file format such as
+                                @filepath{.mp3}.}]}
 
 
 @defproc[(position-integer? [v any/c]) boolean?]{

gui-lib/info.rkt

@@ -30,4 +30,4 @@
 
 (define pkg-authors '(mflatt robby))
 
-(define version "1.21")
+(define version "1.22")

gui-lib/mred/private/wx/win32/sound.rkt

@@ -1,11 +1,8 @@
 #lang racket/base
 (require ffi/unsafe
+	 ffi/winapi
          racket/class
-         racket/runtime-path
-	 setup/cross-system
-	 (for-syntax racket/base
-		     setup/cross-system)
-	 "../../lock.rkt"
+         "../../lock.rkt"
          "utils.rkt"
          "types.rkt"
          "const.rkt")
@@ -13,67 +10,55 @@
 (provide
  (protect-out play-sound))
 
-(define-winmm PlaySoundW (_wfun _string/utf-16 _pointer _DWORD -> _BOOL))
+(define BUFFER-SIZE 512)
+(define BUFFER-BYTES-SIZE (* 2 BUFFER-SIZE))
 
-(define SND_SYNC   #x0000)
-(define SND_ASYNC  #x0001)
-(define SND_NOSTOP #x0010)
+(define-winmm mciGetErrorStringW
+  (_fun _int
+	[buf : _pointer = (malloc BUFFER-BYTES-SIZE)]
+	[_int = BUFFER-SIZE]
+	-> [ret : _bool]
+	-> (and ret (cast buf _pointer _string/utf-16))))
 
-;; Plays a sound using PlaySOund directly, which is limited
-;; to playing a single sound at a time in the process:
-(define (in-process-play-sound path async?)
-  (let ([path (simplify-path path #f)]
-	[done (make-semaphore)])
-    (and (let ([p (path->string
-		   (cleanse-path (path->complete-path path)))])
-	   (atomically
-	    (when previous-done-sema (semaphore-post previous-done-sema))
-	    (set! previous-done-sema done)
-	    (PlaySoundW p #f SND_ASYNC)))
-	 (or async?
-	     ;; Implement synchronous playing by polling, where
-	     ;; PlaySound with no sound file and SND_NOSTOP polls.
-	     (let loop ()
-	       (sleep 0.1)
-	       (or (semaphore-try-wait? done)
-		   (PlaySoundW #f #f (bitwise-ior SND_ASYNC SND_NOSTOP))
-		   (loop)))))))
-(define previous-done-sema #f)
+(define-winmm mciSendStringW
+  (_fun _string/utf-16 [_pointer = #f] [_int = 0] [_pointer = #f]
+	-> [ret : _int]
+	-> (if (zero? ret)
+	       (void)
+	       (error 'mciSendStringW "~a" (mciGetErrorStringW ret)))))
 
-;; Runs a separate process to play a sound using a very
-;; small executable:
-(define (other-process-play-sound path async?)
-  (define c (make-custodian))
-  (define-values (s i o e)
-    (parameterize ([current-custodian c]
-		   [current-subprocess-custodian-mode 'kill])
-      (subprocess #f #f #f
-		  (car racket-playsound.exe)
-		  'exact
-		  (path->string
-		   (simplify-path
-		    (path->complete-path path))))))
-  (close-input-port i)
-  (close-input-port e)
-  (close-output-port o)
-  (unless async?
-    (dynamic-wind
-     void
-     (lambda () (subprocess-wait s))
-     (lambda () (subprocess-kill s #t))))
-  (define n (subprocess-status s))
-  ;; Sound may be still playing, but assume success if it
-  ;; hasn't failed, yet:
-  (or (symbol? n)
-      (zero? n)))
+(define (mci-send fmt . args)
+  (mciSendStringW (apply format fmt args)))
 
-(define-runtime-path-list racket-playsound.exe
-  (if (eq? 'windows (cross-system-type))
-      (list '(so "racket-playsound.exe"))
-      null))
+(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 (play-sound path async?)
-  (if (and (pair? racket-playsound.exe)
-	   (file-exists? (car racket-playsound.exe)))
-      (other-process-play-sound path async?)
-      (in-process-play-sound path async?)))
+(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 (done msec)
+    (when msec (sleep (/ msec 1000)))
+    (mci-send "close ~a" id))
+  (with-handlers ([void (lambda (e) (done #f) (raise e))])
+    ;; adding "type waveaudio" will make it work only for wavs (no mp3 etc)
+    (mci-send "open \"~a\" alias ~a" (simplify-path file) id)
+    (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 5000)))) (done len)))
+  ;; Report success, since otherwise we throw an error:
+  #t)