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
+         "../../lock.rkt"
-	 setup/cross-system
-	 (for-syntax racket/base
-		     setup/cross-system)
-	 "../../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-winmm mciGetErrorStringW
-(define SND_ASYNC  #x0001)
+  (_fun _int
-(define SND_NOSTOP #x0010)
+	[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
+(define-winmm mciSendStringW
-;; to playing a single sound at a time in the process:
+  (_fun _string/utf-16 [_pointer = #f] [_int = 0] [_pointer = #f]
-(define (in-process-play-sound path async?)
+	-> [ret : _int]
-  (let ([path (simplify-path path #f)]
+	-> (if (zero? ret)
-	[done (make-semaphore)])
+	       (void)
-    (and (let ([p (path->string
+	       (error 'mciSendStringW "~a" (mciGetErrorStringW ret)))))
-		   (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)
 
-;; Runs a separate process to play a sound using a very
+(define (mci-send fmt . args)
-;; small executable:
+  (mciSendStringW (apply format fmt args)))
-(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-runtime-path-list racket-playsound.exe
+(define-winmm mciSendStringW*
-  (if (eq? 'windows (cross-system-type))
+  (_fun _string/utf-16
-      (list '(so "racket-playsound.exe"))
+	[buf : _pointer = (malloc BUFFER-BYTES-SIZE)]
-      null))
+	[_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?)
+(define (mci-send* fmt . args)
-  (if (and (pair? racket-playsound.exe)
+  (mciSendStringW* (apply format fmt args)))
-	   (file-exists? (car racket-playsound.exe)))
+
-      (other-process-play-sound path async?)
+(define (play-sound file async?)
-      (in-process-play-sound path 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)