source: trunk/Packages/CevoComponents/Sound.pas@ 317

Last change on this file since 317 was 317, checked in by chronos, 9 months ago
  • Added: Allow to set gamma corection in settings dialog.
File size: 9.7 KB
Line 
1unit Sound;
2
3interface
4
5uses
6 SysUtils, Classes, Graphics, Controls, Forms, fgl, FileUtil,
7 StringTables, Directories, LCLType
8 {$IFDEF WINDOWS}, MMSystem, Windows{$ENDIF}
9 {$IFDEF LINUX}, Process, AsyncProcess2{$ENDIF};
10
11type
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 m: 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 LINUX}
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
48function PrepareSound(FileName: string): Integer;
49procedure PlaySound(FileName: string);
50function Play(Item: string; Index: Integer = -1): Boolean;
51procedure PreparePlay(Item: string; Index: Integer = -1);
52
53var
54 Sounds: TStringTable;
55 SoundMode: TSoundMode;
56 SoundPlayer: TSoundPlayer;
57 SoundList: TFPGObjectList<TSound>;
58 PlayingSound: TSound;
59
60
61implementation
62
63{$R *.lfm}
64
65{$IFDEF LINUX}
66resourcestring
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
71constructor TSound.Create(const FileName: string);
72{$IFDEF WINDOWS}
73var
74 OpenParm: TMCI_Open_Parms;
75{$ENDIF}
76begin
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 LINUX}
91 PlayCommand := GetNonWindowsPlayCommand;
92 FDeviceID := 1;
93 {$ENDIF}
94end;
95
96destructor TSound.Destroy;
97begin
98 {$IFDEF WINDOWS}
99 if FDeviceID <> 0 then
100 mciSendCommand(FDeviceID, MCI_CLOSE, MCI_WAIT, 0);
101 {$ENDIF}
102 {$IFDEF LINUX}
103 FreeAndNil(SoundPlayerSyncProcess);
104 FreeAndNil(SoundPlayerAsyncProcess);
105 {$ENDIF}
106 inherited;
107end;
108
109function TSound.GetNonWindowsPlayCommand: string;
110begin
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';
152end;
153
154
155procedure TSound.Play(Handle: HWND);
156{$IFDEF WINDOWS}
157var
158 PlayParm: TMCI_Play_Parms;
159{$ENDIF}
160{$IFDEF LINUX}
161var
162 L: TStringList;
163 I: Integer;
164{$ENDIF}
165begin
166 {$IFDEF WINDOWS}
167 if FDeviceID <> 0 then
168 begin
169 PlayParm.dwCallback := Handle;
170 mciSendCommand(FDeviceID, MCI_PLAY, MCI_NOTIFY, DWORD_PTR(@PlayParm));
171 end
172 {$ENDIF}
173 {$IFDEF LINUX}
174 // How to play in Linux? Use generic Linux commands
175 // Use asyncprocess to play sound as SND_ASYNC
176 // proceed if we managed to find a valid command
177 if PlayCommand <> '' then begin
178 L := TStringList.Create;
179 try
180 L.Delimiter := ' ';
181 L.DelimitedText := PlayCommand;
182 if PlayStyle = psASync then begin
183 if SoundPlayerAsyncProcess = nil then
184 SoundPlayerAsyncProcess := TAsyncProcess.Create(nil);
185 SoundPlayerAsyncProcess.CurrentDirectory := ExtractFileDir(FFilename);
186 SoundPlayerAsyncProcess.Executable := FindDefaultExecutablePath(L[0]);
187 SoundPlayerAsyncProcess.Parameters.Clear;
188 for I := 1 to L.Count - 1 do
189 SoundPlayerAsyncProcess.Parameters.Add(L[I]);
190 SoundPlayerAsyncProcess.Parameters.Add(FFilename);
191 try
192 SoundPlayerAsyncProcess.Execute;
193 except
194 On E: Exception do
195 E.CreateFmt(SUnableToPlay, ['paASync', FFilename, E.Message]);
196 end;
197 PlayingSound := nil;
198 end else begin
199 if SoundPlayerSyncProcess = nil then
200 SoundPlayerSyncProcess := TProcess.Create(nil);
201 SoundPlayerSyncProcess.CurrentDirectory := ExtractFileDir(FFilename);
202 SoundPlayerSyncProcess.Executable := FindDefaultExecutablePath(L[0]);
203 SoundPlayersyncProcess.Parameters.Clear;
204 for I := 1 to L.Count - 1 do
205 SoundPlayerSyncProcess.Parameters.Add(L[I]);
206 SoundPlayerSyncProcess.Parameters.Add(FFilename);
207 try
208 SoundPlayerSyncProcess.Execute;
209 SoundPlayersyncProcess.WaitOnExit;
210 except
211 On E: Exception do
212 E.CreateFmt(SUnableToPlay, ['paSync', FFilename, E.Message]);
213 end;
214 PlayingSound := nil;
215 end;
216 finally
217 FreeAndNil(L);
218 end;
219 end
220 else
221 raise Exception.CreateFmt(SPlayCommandNotWork, [PlayCommand]);
222 {$ENDIF}
223end;
224
225procedure TSound.Stop;
226begin
227 {$IFDEF WINDOWS}
228 mciSendCommand(FDeviceID, MCI_STOP, 0, 0);
229 {$ENDIF}
230 {$IFDEF LINUX}
231 if SoundPlayerSyncProcess <> nil then SoundPlayerSyncProcess.Terminate(1);
232 if SoundPlayerAsyncProcess <> nil then SoundPlayerAsyncProcess.Terminate(1);
233 {$ENDIF}
234end;
235
236procedure TSound.Reset;
237begin
238 {$IFDEF WINDOWS}
239 mciSendCommand(FDeviceID, MCI_SEEK, MCI_SEEK_TO_START, 0);
240 {$ENDIF}
241end;
242
243{$IFDEF WINDOWS}
244function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;
245var
246 Message: TMessage;
247begin
248 if (uMsg = MM_MCINOTIFY) then begin
249 Message.msg := uMsg;
250 Message.wParam := wParam;
251 Message.lParam := lParam;
252 SoundPlayer.OnMCI(Message);
253 end;
254 Result := CallWindowProc(SoundPlayer.PrevWndProc, Ahwnd, uMsg, WParam, LParam);
255end;
256
257procedure TSoundPlayer.OnMCI(var m: TMessage);
258begin
259 if (m.wParam = MCI_NOTIFY_SUCCESSFUL) and (PlayingSound <> nil) then
260 begin
261 PlayingSound.Reset;
262 PlayingSound := nil;
263 end;
264end;
265
266constructor TSoundPlayer.Create(AOwner: TComponent);
267begin
268 inherited;
269 // MM_MCINOTIFY is not handled by LCL, fallback to low lever handling
270 // https://wiki.lazarus.freepascal.org/Win32/64_Interface#Processing_non-user_messages_in_your_window
271 PrevWndProc := Windows.WNDPROC(SetWindowLongPtr(Self.Handle, GWL_WNDPROC, PtrInt(@WndCallback)));
272end;
273{$ENDIF}
274
275function PrepareSound(FileName: string): Integer;
276begin
277 Result := 0;
278 while (Result < SoundList.Count) and (SoundList[result].FFileName <> FileName) do
279 Inc(Result);
280 if Result = SoundList.Count then begin
281 // First time this sound is played
282 SoundList.Add(TSound.Create(FileName));
283 Result := SoundList.Count - 1;
284 end;
285end;
286
287procedure PlaySound(FileName: string);
288begin
289 if PlayingSound <> nil then Exit;
290 if SoundPlayer = nil then
291 Application.CreateForm(TSoundPlayer, SoundPlayer);
292 PlayingSound := SoundList[PrepareSound(FileName)];
293 if PlayingSound.FDeviceID = 0 then
294 PlayingSound := nil
295 else
296 PlayingSound.Play(SoundPlayer.Handle);
297end;
298
299function Play(Item: string; Index: Integer = -1): Boolean;
300var
301 WavFileName: string;
302begin
303 Result := False;
304 if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then
305 begin
306 Result := True;
307 Exit;
308 end;
309 WavFileName := Sounds.Lookup(Item, Index);
310 Assert(WavFileName[1] <> '[');
311 Result := (WavFileName <> '') and (WavFileName[1] <> '[') and (WavFileName <> '*');
312 if Result then
313 // SndPlaySound(pchar(GetSoundsDir + DirectorySeparator + WavFileName + '.wav'), SND_ASYNC)
314 PlaySound(GetSoundsDir + DirectorySeparator + WavFileName);
315end;
316
317procedure PreparePlay(Item: string; Index: Integer = -1);
318var
319 WavFileName: string;
320begin
321 if (Sounds = nil) or (SoundMode = smOff) or (Item = '') then
322 Exit;
323 WavFileName := Sounds.Lookup(Item, Index);
324 Assert(WavFileName[1] <> '[');
325 if (WavFileName <> '') and (WavFileName[1] <> '[') and (WavFileName <> '*') then
326 PrepareSound(GetSoundsDir + DirectorySeparator + WavFileName);
327end;
328
329procedure UnitInit;
330begin
331 SoundList := TFPGObjectList<TSound>.Create;
332 PlayingSound := nil;
333 SoundPlayer := nil;
334end;
335
336procedure UnitDone;
337begin
338 if PlayingSound <> nil then begin
339 PlayingSound.Stop;
340 Sleep(222);
341 end;
342 FreeAndNil(SoundList);
343 if Sounds <> nil then
344 FreeAndNil(Sounds);
345end;
346
347initialization
348
349UnitInit;
350
351finalization
352
353UnitDone;
354
355end.
Note: See TracBrowser for help on using the repository browser.