1 | unit Sound;
|
---|
2 |
|
---|
3 | interface
|
---|
4 |
|
---|
5 | uses
|
---|
6 | SysUtils, Classes, Graphics, Controls, Forms, Generics.Collections, FileUtil,
|
---|
7 | StringTables, Directories, LCLType
|
---|
8 | {$IFDEF WINDOWS}, MMSystem, Windows{$ENDIF}
|
---|
9 | {$IFDEF UNIX}, Process, AsyncProcess2{$ENDIF};
|
---|
10 |
|
---|
11 | type
|
---|
12 | TPlayStyle = (psAsync, psSync);
|
---|
13 | TSoundMode = (smOff, smOn, smOnAlt);
|
---|
14 |
|
---|
15 | { TSoundPlayer }
|
---|
16 |
|
---|
17 | TSoundPlayer = class(TForm)
|
---|
18 | private
|
---|
19 | {$IFDEF WINDOWS}
|
---|
20 | PrevWndProc: WNDPROC;
|
---|
21 | procedure OnMCI(var Msg: TMessage); message MM_MCINOTIFY;
|
---|
22 | public
|
---|
23 | constructor Create(AOwner: TComponent); override;
|
---|
24 | {$ENDIF}
|
---|
25 | end;
|
---|
26 |
|
---|
27 | { TSound }
|
---|
28 |
|
---|
29 | TSound = class
|
---|
30 | private
|
---|
31 | {$IFDEF UNIX}
|
---|
32 | PlayCommand: string;
|
---|
33 | SoundPlayerAsyncProcess: TAsyncProcess;
|
---|
34 | SoundPlayerSyncProcess: TProcess;
|
---|
35 | {$ENDIF}
|
---|
36 | function GetNonWindowsPlayCommand: string;
|
---|
37 | public
|
---|
38 | FDeviceID: Word;
|
---|
39 | FFileName: string;
|
---|
40 | PlayStyle: TPlayStyle;
|
---|
41 | constructor Create(const FileName: string);
|
---|
42 | destructor Destroy; override;
|
---|
43 | procedure Play(Handle: HWND);
|
---|
44 | procedure Stop;
|
---|
45 | procedure Reset;
|
---|
46 | end;
|
---|
47 |
|
---|
48 | function PrepareSound(FileName: string): Integer;
|
---|
49 | procedure PlaySound(FileName: string);
|
---|
50 | function Play(Item: string; Index: Integer = -1): Boolean;
|
---|
51 | procedure PreparePlay(Item: string; Index: Integer = -1);
|
---|
52 |
|
---|
53 | var
|
---|
54 | Sounds: TStringTable;
|
---|
55 | SoundMode: TSoundMode;
|
---|
56 | SoundPlayer: TSoundPlayer;
|
---|
57 | SoundList: TObjectList<TSound>;
|
---|
58 | PlayingSound: TSound;
|
---|
59 |
|
---|
60 |
|
---|
61 | implementation
|
---|
62 |
|
---|
63 | {$R *.lfm}
|
---|
64 |
|
---|
65 | {$IFDEF UNIX}
|
---|
66 | resourcestring
|
---|
67 | SUnableToPlay = 'PlayStyle=%s: Unable to play %s Message:%s';
|
---|
68 | SPlayCommandNotWork = 'The play command %s does not work on your system';
|
---|
69 | {$ENDIF}
|
---|
70 |
|
---|
71 | constructor TSound.Create(const FileName: string);
|
---|
72 | {$IFDEF WINDOWS}
|
---|
73 | var
|
---|
74 | OpenParm: TMCI_Open_Parms;
|
---|
75 | {$ENDIF}
|
---|
76 | begin
|
---|
77 | PlayStyle := psAsync;
|
---|
78 | FFileName := FileName;
|
---|
79 | {$IFDEF WINDOWS}
|
---|
80 | FDeviceID := 0;
|
---|
81 | if FileExists(FFileName) then begin
|
---|
82 | OpenParm.dwCallback := 0;
|
---|
83 | OpenParm.lpstrDeviceType := 'WaveAudio';
|
---|
84 | OpenParm.lpstrElementName := PChar(FFileName);
|
---|
85 | mciSendCommand(0, MCI_Open, MCI_WAIT or MCI_OPEN_ELEMENT or
|
---|
86 | MCI_OPEN_SHAREABLE, DWORD_PTR(@OpenParm));
|
---|
87 | FDeviceID := OpenParm.wDeviceID;
|
---|
88 | end
|
---|
89 | {$ENDIF}
|
---|
90 | {$IFDEF UNIX}
|
---|
91 | PlayCommand := GetNonWindowsPlayCommand;
|
---|
92 | FDeviceID := 1;
|
---|
93 | {$ENDIF}
|
---|
94 | end;
|
---|
95 |
|
---|
96 | destructor TSound.Destroy;
|
---|
97 | begin
|
---|
98 | {$IFDEF WINDOWS}
|
---|
99 | if FDeviceID <> 0 then
|
---|
100 | mciSendCommand(FDeviceID, MCI_CLOSE, MCI_WAIT, 0);
|
---|
101 | {$ENDIF}
|
---|
102 | {$IFDEF UNIX}
|
---|
103 | FreeAndNil(SoundPlayerSyncProcess);
|
---|
104 | FreeAndNil(SoundPlayerAsyncProcess);
|
---|
105 | {$ENDIF}
|
---|
106 | inherited;
|
---|
107 | end;
|
---|
108 |
|
---|
109 | function TSound.GetNonWindowsPlayCommand: string;
|
---|
110 | begin
|
---|
111 | Result := '';
|
---|
112 | // Try ffplay
|
---|
113 | if (Result = '') then
|
---|
114 | if (FindDefaultExecutablePath('ffplay') <> '') then
|
---|
115 | Result := 'ffplay -autoexit -nodisp -loglevel quiet';
|
---|
116 | // Try play
|
---|
117 | if (Result = '') then
|
---|
118 | if (FindDefaultExecutablePath('play') <> '') then
|
---|
119 | Result := 'play -q';
|
---|
120 | // Try aplay
|
---|
121 | if (Result = '') then
|
---|
122 | if (FindDefaultExecutablePath('aplay') <> '') then
|
---|
123 | Result := 'aplay -q';
|
---|
124 | // Try paplay
|
---|
125 | if (Result = '') then
|
---|
126 | if (FindDefaultExecutablePath('paplay') <> '') then
|
---|
127 | Result := 'paplay';
|
---|
128 | // Try mplayer
|
---|
129 | if (Result = '') then
|
---|
130 | if (FindDefaultExecutablePath('mplayer') <> '') then
|
---|
131 | Result := 'mplayer -really-quiet';
|
---|
132 | // Try CMus
|
---|
133 | if (Result = '') then
|
---|
134 | if (FindDefaultExecutablePath('CMus') <> '') then
|
---|
135 | Result := 'CMus';
|
---|
136 | // Try pacat
|
---|
137 | if (Result = '') then
|
---|
138 | if (FindDefaultExecutablePath('pacat') <> '') then
|
---|
139 | Result := 'pacat -p';
|
---|
140 | // Try cvlc
|
---|
141 | if (Result = '') then
|
---|
142 | if (FindDefaultExecutablePath('cvlc') <> '') then
|
---|
143 | Result := 'cvlc -q --play-and-exit';
|
---|
144 | // Try canberra-gtk-play
|
---|
145 | if (Result = '') then
|
---|
146 | if (FindDefaultExecutablePath('canberra-gtk-play') <> '') then
|
---|
147 | Result := 'canberra-gtk-play -c never -f';
|
---|
148 | // Try Macintosh command?
|
---|
149 | if (Result = '') then
|
---|
150 | if (FindDefaultExecutablePath('afplay') <> '') then
|
---|
151 | Result := 'afplay';
|
---|
152 | // Try mpg321
|
---|
153 | if (Result = '') then
|
---|
154 | if (FindDefaultExecutablePath('mpg321') <> '') then
|
---|
155 | Result := 'mpg321 -q';
|
---|
156 | end;
|
---|
157 |
|
---|
158 |
|
---|
159 | procedure TSound.Play(Handle: HWND);
|
---|
160 | {$IFDEF WINDOWS}
|
---|
161 | var
|
---|
162 | PlayParm: TMCI_Play_Parms;
|
---|
163 | {$ENDIF}
|
---|
164 | {$IFDEF UNIX}
|
---|
165 | var
|
---|
166 | L: TStringList;
|
---|
167 | I: Integer;
|
---|
168 | {$ENDIF}
|
---|
169 | begin
|
---|
170 | {$IFDEF WINDOWS}
|
---|
171 | if FDeviceID <> 0 then
|
---|
172 | begin
|
---|
173 | PlayParm.dwCallback := Handle;
|
---|
174 | mciSendCommand(FDeviceID, MCI_PLAY, MCI_NOTIFY, DWORD_PTR(@PlayParm));
|
---|
175 | end
|
---|
176 | {$ENDIF}
|
---|
177 | {$IFDEF UNIX}
|
---|
178 | // How to play in Linux? Use generic Linux commands
|
---|
179 | // Use asyncprocess to play sound as SND_ASYNC
|
---|
180 | // proceed if we managed to find a valid command
|
---|
181 | if PlayCommand <> '' then begin
|
---|
182 | L := TStringList.Create;
|
---|
183 | try
|
---|
184 | L.Delimiter := ' ';
|
---|
185 | L.DelimitedText := PlayCommand;
|
---|
186 | if PlayStyle = psASync then begin
|
---|
187 | if SoundPlayerAsyncProcess = nil then
|
---|
188 | SoundPlayerAsyncProcess := TAsyncProcess.Create(nil);
|
---|
189 | SoundPlayerAsyncProcess.CurrentDirectory := ExtractFileDir(FFilename);
|
---|
190 | SoundPlayerAsyncProcess.Executable := FindDefaultExecutablePath(L[0]);
|
---|
191 | SoundPlayerAsyncProcess.Parameters.Clear;
|
---|
192 | for I := 1 to L.Count - 1 do
|
---|
193 | SoundPlayerAsyncProcess.Parameters.Add(L[I]);
|
---|
194 | SoundPlayerAsyncProcess.Parameters.Add(FFilename);
|
---|
195 | try
|
---|
196 | SoundPlayerAsyncProcess.Execute;
|
---|
197 | except
|
---|
198 | On E: Exception do
|
---|
199 | E.CreateFmt(SUnableToPlay, ['paASync', FFilename, E.Message]);
|
---|
200 | end;
|
---|
201 | PlayingSound := nil;
|
---|
202 | end else begin
|
---|
203 | if SoundPlayerSyncProcess = nil then
|
---|
204 | SoundPlayerSyncProcess := TProcess.Create(nil);
|
---|
205 | SoundPlayerSyncProcess.CurrentDirectory := ExtractFileDir(FFilename);
|
---|
206 | SoundPlayerSyncProcess.Executable := FindDefaultExecutablePath(L[0]);
|
---|
207 | SoundPlayersyncProcess.Parameters.Clear;
|
---|
208 | for I := 1 to L.Count - 1 do
|
---|
209 | SoundPlayerSyncProcess.Parameters.Add(L[I]);
|
---|
210 | SoundPlayerSyncProcess.Parameters.Add(FFilename);
|
---|
211 | try
|
---|
212 | SoundPlayerSyncProcess.Execute;
|
---|
213 | SoundPlayersyncProcess.WaitOnExit;
|
---|
214 | except
|
---|
215 | On E: Exception do
|
---|
216 | E.CreateFmt(SUnableToPlay, ['paSync', FFilename, E.Message]);
|
---|
217 | end;
|
---|
218 | PlayingSound := nil;
|
---|
219 | end;
|
---|
220 | finally
|
---|
221 | FreeAndNil(L);
|
---|
222 | end;
|
---|
223 | end
|
---|
224 | else
|
---|
225 | raise Exception.CreateFmt(SPlayCommandNotWork, [PlayCommand]);
|
---|
226 | {$ENDIF}
|
---|
227 | end;
|
---|
228 |
|
---|
229 | procedure TSound.Stop;
|
---|
230 | begin
|
---|
231 | {$IFDEF WINDOWS}
|
---|
232 | mciSendCommand(FDeviceID, MCI_STOP, 0, 0);
|
---|
233 | {$ENDIF}
|
---|
234 | {$IFDEF UNIX}
|
---|
235 | if SoundPlayerSyncProcess <> nil then SoundPlayerSyncProcess.Terminate(1);
|
---|
236 | if SoundPlayerAsyncProcess <> nil then SoundPlayerAsyncProcess.Terminate(1);
|
---|
237 | {$ENDIF}
|
---|
238 | end;
|
---|
239 |
|
---|
240 | procedure TSound.Reset;
|
---|
241 | begin
|
---|
242 | {$IFDEF WINDOWS}
|
---|
243 | mciSendCommand(FDeviceID, MCI_SEEK, MCI_SEEK_TO_START, 0);
|
---|
244 | {$ENDIF}
|
---|
245 | end;
|
---|
246 |
|
---|
247 | {$IFDEF WINDOWS}
|
---|
248 | function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;
|
---|
249 | var
|
---|
250 | Message: TMessage;
|
---|
251 | begin
|
---|
252 | if (uMsg = MM_MCINOTIFY) then begin
|
---|
253 | Message.msg := uMsg;
|
---|
254 | Message.wParam := wParam;
|
---|
255 | Message.lParam := lParam;
|
---|
256 | SoundPlayer.OnMCI(Message);
|
---|
257 | end;
|
---|
258 | Result := CallWindowProc(SoundPlayer.PrevWndProc, Ahwnd, uMsg, WParam, LParam);
|
---|
259 | end;
|
---|
260 |
|
---|
261 | procedure TSoundPlayer.OnMCI(var Msg: TMessage);
|
---|
262 | begin
|
---|
263 | if (Msg.wParam = MCI_NOTIFY_SUCCESSFUL) and (PlayingSound <> nil) then
|
---|
264 | begin
|
---|
265 | PlayingSound.Reset;
|
---|
266 | PlayingSound := nil;
|
---|
267 | end;
|
---|
268 | end;
|
---|
269 |
|
---|
270 | constructor TSoundPlayer.Create(AOwner: TComponent);
|
---|
271 | begin
|
---|
272 | inherited;
|
---|
273 | // MM_MCINOTIFY is not handled by LCL, fallback to low lever handling
|
---|
274 | // https://wiki.lazarus.freepascal.org/Win32/64_Interface#Processing_non-user_messages_in_your_window
|
---|
275 | PrevWndProc := Windows.WNDPROC(SetWindowLongPtr(Self.Handle, GWL_WNDPROC, PtrInt(@WndCallback)));
|
---|
276 | end;
|
---|
277 | {$ENDIF}
|
---|
278 |
|
---|
279 | function PrepareSound(FileName: string): Integer;
|
---|
280 | begin
|
---|
281 | Result := 0;
|
---|
282 | while (Result < SoundList.Count) and (SoundList[Result].FFileName <> FileName) do
|
---|
283 | Inc(Result);
|
---|
284 | if Result = SoundList.Count then begin
|
---|
285 | // First time this sound is played
|
---|
286 | SoundList.Add(TSound.Create(FileName));
|
---|
287 | Result := SoundList.Count - 1;
|
---|
288 | end;
|
---|
289 | end;
|
---|
290 |
|
---|
291 | procedure PlaySound(FileName: string);
|
---|
292 | begin
|
---|
293 | if PlayingSound <> nil then Exit;
|
---|
294 | if SoundPlayer = nil then
|
---|
295 | Application.CreateForm(TSoundPlayer, SoundPlayer);
|
---|
296 | PlayingSound := SoundList[PrepareSound(FileName)];
|
---|
297 | if PlayingSound.FDeviceID = 0 then
|
---|
298 | PlayingSound := nil
|
---|
299 | else
|
---|
300 | PlayingSound.Play(SoundPlayer.Handle);
|
---|
301 | end;
|
---|
302 |
|
---|
303 | function Play(Item: string; Index: Integer = -1): Boolean;
|
---|
304 | var
|
---|
305 | WavFileName: string;
|
---|
306 | begin
|
---|
307 | Result := False;
|
---|
308 | if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then
|
---|
309 | begin
|
---|
310 | Result := True;
|
---|
311 | Exit;
|
---|
312 | end;
|
---|
313 | WavFileName := Sounds.Lookup(Item, Index);
|
---|
314 | Assert(WavFileName[1] <> '[');
|
---|
315 | Result := (WavFileName <> '') and (WavFileName[1] <> '[') and (WavFileName <> '*');
|
---|
316 | if Result then
|
---|
317 | // SndPlaySound(PChar(GetSoundsDir + DirectorySeparator + WavFileName + '.wav'), SND_ASYNC)
|
---|
318 | PlaySound(GetSoundsDir + DirectorySeparator + WavFileName);
|
---|
319 | end;
|
---|
320 |
|
---|
321 | procedure PreparePlay(Item: string; Index: Integer = -1);
|
---|
322 | var
|
---|
323 | WavFileName: string;
|
---|
324 | begin
|
---|
325 | if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then
|
---|
326 | Exit;
|
---|
327 | WavFileName := Sounds.Lookup(Item, Index);
|
---|
328 | Assert(WavFileName[1] <> '[');
|
---|
329 | if (WavFileName <> '') and (WavFileName[1] <> '[') and (WavFileName <> '*') then
|
---|
330 | PrepareSound(GetSoundsDir + DirectorySeparator + WavFileName);
|
---|
331 | end;
|
---|
332 |
|
---|
333 | procedure UnitInit;
|
---|
334 | begin
|
---|
335 | SoundList := TObjectList<TSound>.Create;
|
---|
336 | PlayingSound := nil;
|
---|
337 | SoundPlayer := nil;
|
---|
338 | end;
|
---|
339 |
|
---|
340 | procedure UnitDone;
|
---|
341 | begin
|
---|
342 | if PlayingSound <> nil then begin
|
---|
343 | PlayingSound.Stop;
|
---|
344 | Sleep(222);
|
---|
345 | end;
|
---|
346 | FreeAndNil(SoundList);
|
---|
347 | if Sounds <> nil then
|
---|
348 | FreeAndNil(Sounds);
|
---|
349 | end;
|
---|
350 |
|
---|
351 | initialization
|
---|
352 |
|
---|
353 | UnitInit;
|
---|
354 |
|
---|
355 | finalization
|
---|
356 |
|
---|
357 | UnitDone;
|
---|
358 |
|
---|
359 | end.
|
---|