| 1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
| ///////////////////////////////////////////////////////////////////////////
// //
// Copyright (c) 2015 by Charta Software B.V. //
// All rights reserved //
// //
// Version: 1.7.0.83525 //
// Web site: https://pascal.chartasoftware.com/ //
// //
// This code and information are provided "as is" without warranty of //
// any kind. Dissemination of this information or reproduction of //
// this material is strictly forbidden unless prior written permission //
// is obtained from Charta Software B.V.. //
// //
///////////////////////////////////////////////////////////////////////////
unit Windows.Event.Queue;
interface
uses
Event,
Event.Queue,
Integer._32.Positive,
Object_.List,
Thread.WaitableObject,
Windows.Api.Messages,
Windows.Api.Type_,
Windows.Window;
type
TMessageWindow = class(TWindowsWindow)
protected
function HandleQueueEvent(Event: TEvent): LRESULT;
function WindowProcedure(Message: TPositiveInteger32; wParam: TWParam; lParam: TLParam): LRESULT; override;
public
constructor Create(); reintroduce; virtual;
end;
TWindowsEventQueue = class(TEventQueue)
private
FThreadIdentifier: TPositiveInteger32;
MessageWindow: TMessageWindow;
function ConvertMessageToEvent(const Message: TMsg): TEvent;
procedure CreateQueueForCurrentThread();
protected
function GetThreadIdentifier(): TPositiveInteger32; override;
public
constructor Create(); virtual;
destructor Destroy(); override;
procedure Queue(Event: TEvent); override;
function Dequeue(): TEvent; override;
function DequeueIfAvailable(): TEvent; override;
function WaitForAny(Objects: TObjectList<TWaitableObject>; TimeOut_Milliseconds: TPositiveInteger32): TWaitableObject; override;
end;
var
CM_QUEUE_EVENT: DWORD;
implementation
uses
Exception,
Geometry._2d.Integer32.Rectangle,
Integer._32,
Integer.Interval,
Task.Execution.EventQueue.Event,
Task.Scheduler,
Windows.Api.Error,
Windows.Api.Kernel.Synchronization,
Windows.Api.Kernel.Thread,
Windows.Api.UserInterface;
{ TWindowsEventQueue }
function TWindowsEventQueue.ConvertMessageToEvent(const Message: TMsg): TEvent;
begin
if Message.message = CM_QUEUE_EVENT then
Result := TEvent(Message.wParam)
else
raise EException.Create('Unknown message detected');
end;
constructor TWindowsEventQueue.Create();
begin
inherited Create();
FThreadIdentifier := GetCurrentThreadId();
CreateQueueForCurrentThread();
MessageWindow := TMessageWindow.Create();
end;
procedure TWindowsEventQueue.CreateQueueForCurrentThread();
var
Message: TMsg;
begin
PeekMessage(Message, 0, WM_USER, WM_USER, PM_NOREMOVE);
end;
function TWindowsEventQueue.Dequeue(): TEvent;
var
Message: TMsg;
begin
if GetMessage(Message, 0, 0, 0) then
Result := ConvertMessageToEvent(Message)
else
Result := nil;
end;
function TWindowsEventQueue.DequeueIfAvailable(): TEvent;
var
Message: TMsg;
begin
if PeekMessage(Message, 0, 0, 0, PM_REMOVE) then
Result := ConvertMessageToEvent(Message)
else
Result := nil;
end;
destructor TWindowsEventQueue.Destroy();
begin
MessageWindow.Free();
inherited Destroy();
end;
function TWindowsEventQueue.GetThreadIdentifier(): TPositiveInteger32;
begin
Result := FThreadIdentifier;
end;
procedure TWindowsEventQueue.Queue(Event: TEvent);
begin
// TODO: We use PostThreadMessage() here, however, currently this results in lost messages when the queue is associated
// with a windows and the user resizes or moves the window.
if not PostMessage(MessageWindow.Handle, CM_QUEUE_EVENT, TWParam(Event), 0) then
EWindows32.RaiseLast();
end;
function TWindowsEventQueue.WaitForAny(Objects: TObjectList<TWaitableObject>; TimeOut_Milliseconds: TPositiveInteger32): TWaitableObject;
var
WaitObjects: array of THandle;
i: TInteger32;
WaitResult: DWORD;
begin
if Objects.Count <= MAXIMUM_WAIT_OBJECTS then
begin
SetLength(WaitObjects, Objects.Count);
for i := 0 to Objects.Count - 1 do
WaitObjects[i] := Objects[i].GetWaitHandle();
WaitResult := MsgWaitForMultipleObjects(Length(WaitObjects), @WaitObjects[0], False, TimeOut_Milliseconds, QS_ALLINPUT);
Result := nil;
case WaitResult of
WAIT_FAILED:
EWindows32.RaiseLast();
WAIT_TIMEOUT:
Result := nil;
else if TIntegerInterval.NewFromOffsetSize(WAIT_OBJECT_0, Objects.Count).Contains(WaitResult) then
Result := Objects.Find(TWaitableObject.TEqualHandle.Create((WaitObjects[WaitResult - WAIT_OBJECT_0])))
else if WaitResult = WAIT_OBJECT_0 + DWORD(Objects.Count) then
Result := Self
else
raise EException.Create('Unexpected wait result');
end;
end
else
raise EException.Create('#Objects to wait for exceeds maximum');
end;
{ TMessageWindow }
constructor TMessageWindow.Create();
begin
inherited Create('Message', 0, 0, '', HWND_MESSAGE, TInteger32Rectangle.New(0, 0, -1, -1));
end;
function TMessageWindow.HandleQueueEvent(Event: TEvent): LRESULT;
var
ExecuteTaskInEventQueueEvent: TExecuteTaskInEventQueueEvent;
begin
if Event is TExecuteTaskInEventQueueEvent then
begin
ExecuteTaskInEventQueueEvent := Event as TExecuteTaskInEventQueueEvent;
ExecuteTaskInEventQueueEvent.Task.Execute();
case ExecuteTaskInEventQueueEvent.Wait of
TWaitType.DontWait:
ExecuteTaskInEventQueueEvent.Free();
TWaitType.Wait:
ExecuteTaskInEventQueueEvent.ExecutedEvent.Signal();
else
raise EException.Create('Unknown wait type');
end;
end
else
Event.Free();
Result := 0;
end;
function TMessageWindow.WindowProcedure(Message: TPositiveInteger32; wParam: TWParam; lParam: TLParam): LRESULT;
begin
if Message = CM_QUEUE_EVENT then
Result := HandleQueueEvent(TEvent(wParam))
else
Result := inherited WindowProcedure(Message, wParam, lParam);
end;
initialization
CM_QUEUE_EVENT := RegisterWindowMessage('CM_QUEUE_EVENT');
end.
|