ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/3.0/FB30Events.pas
Revision: 381
Committed: Sat Jan 15 00:06:22 2022 UTC (3 days, 15 hours ago) by tony
File size: 8817 byte(s)
Log Message:
Release Candidate 1
Line File contents
1 (*
2 * Firebird Interface (fbintf). The fbintf components provide a set of
3 * Pascal language bindings for the Firebird API.
4 *
5 * The contents of this file are subject to the Initial Developer's
6 * Public License Version 1.0 (the "License"); you may not use this
7 * file except in compliance with the License. You may obtain a copy
8 * of the License here:
9 *
10 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
11 *
12 * Software distributed under the License is distributed on an "AS
13 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14 * implied. See the License for the specific language governing rights
15 * and limitations under the License.
16 *
17 * The Initial Developer of the Original Code is Tony Whyman.
18 *
19 * The Original Code is (C) 2016 Tony Whyman, MWA Software
20 * (http://www.mwasoftware.co.uk).
21 *
22 * All Rights Reserved.
23 *
24 * Contributor(s): ______________________________________.
25 *
26 *)
27 unit FB30Events;
28 {$IFDEF MSWINDOWS}
29 {$DEFINE WINDOWS}
30 {$ENDIF}
31
32 {$IFDEF FPC}
33 {$mode delphi}
34 {$interfaces COM}
35 {$ENDIF}
36
37 { $DEFINE EVENTDEBUG}
38
39 interface
40
41 uses
42 {$IFDEF WINDOWS}Windows, {$ENDIF} Classes, SysUtils, Firebird, IB, FB30ClientAPI, FB30Attachment,
43 syncobjs, FBEvents;
44
45 type
46 TFB30Events = class;
47
48 { TEventhandlerInterface }
49
50 TEventhandlerInterface = class(Firebird.IEventCallbackImpl)
51 private
52 FOwner: TFB30Events;
53 FName: AnsiString;
54 FRef: integer;
55 {$IFDEF WINDOWS}
56 {Make direct use of Windows API as TEventObject don't seem to work under
57 Windows!}
58 FEventHandler: THandle;
59 {$ELSE}
60 FEventWaiting: TEventObject;
61 {$ENDIF}
62 public
63 constructor Create(aOwner: TFB30Events; aName: AnsiString);
64 destructor Destroy; override;
65 procedure addRef(); override;
66 function release(): Integer; override;
67 procedure eventCallbackFunction(length: Cardinal; events: BytePtr); override;
68 procedure WaitForEvent;
69 procedure CancelWait;
70 end;
71
72 { TFB30Events }
73
74 TFB30Events = class(TFBEvents,IEvents)
75 private
76 FAttachmentIntf: Firebird.IAttachment;
77 FEventHandlerThread: TObject;
78 FEventsIntf: Firebird.IEvents;
79 FAsyncEventCallback: TEventhandlerInterface;
80 FSyncEventCallback: TEventhandlerInterface;
81 FFirebird30ClientAPI: TFB30ClientAPI;
82 procedure InternalAsyncWaitForEvent(EventHandler: TEventHandler; EventCallBack: TEventhandlerInterface);
83 procedure ReleaseIntf;
84 protected
85 procedure CancelEvents(Force: boolean = false); override;
86 function GetIEvents: IEvents; override;
87 public
88 constructor Create(DBAttachment: TFB30Attachment; Events: TStrings);
89 destructor Destroy; override;
90
91 {IEvents}
92 procedure WaitForEvent; override;
93 procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
94 end;
95
96 implementation
97
98 uses FBMessages, FBClientAPI;
99
100 type
101 { TEventHandlerThread }
102
103 TEventHandlerThread = class(TThread)
104 private
105 FOwner: TFB30Events;
106 FEventHandler: TEventhandlerInterface;
107 protected
108 procedure Execute; override;
109 public
110 constructor Create(Owner: TFB30Events; EventHandler: TEventhandlerInterface);
111 procedure Terminate;
112 end;
113
114 constructor TEventhandlerInterface.Create(aOwner: TFB30Events; aName: AnsiString);
115 var
116 PSa : PSecurityAttributes;
117 {$IFDEF WINDOWS}
118 Sd : TSecurityDescriptor;
119 Sa : TSecurityAttributes;
120 begin
121 InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
122 SetSecurityDescriptorDacl(@Sd,true,nil,false);
123 Sa.nLength := SizeOf(Sa);
124 Sa.lpSecurityDescriptor := @Sd;
125 Sa.bInheritHandle := true;
126 PSa := @Sa;
127 {$ELSE}
128 GUID : TGUID;
129 begin
130 PSa:= nil;
131 {$ENDIF}
132 inherited Create;
133 {$IFDEF WINDOWS}
134 FEventHandler := CreateEvent(PSa,false,false,nil);
135 {$ELSE}
136 CreateGuid(GUID);
137 FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
138 {$ENDIF}
139 FOWner := aOwner;
140 FName := aName;
141 addRef;
142 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Create'); {$ENDIF}
143 end;
144
145 destructor TEventhandlerInterface.Destroy;
146 begin
147 {$IFDEF WINDOWS}
148 CloseHandle(FEventHandler);
149 {$ELSE}
150 if assigned(FEventWaiting) then FEventWaiting.Free;
151 {$ENDIF}
152 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Destroy'); {$ENDIF}
153 inherited Destroy;
154 end;
155
156 procedure TEventhandlerInterface.addRef;
157 begin
158 Inc(FRef);
159 {$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
160 end;
161
162 function TEventhandlerInterface.release: Integer;
163 begin
164 Dec(FRef);
165 {$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
166 if FRef = 0 then Free;
167 Result := FRef;
168 end;
169
170 procedure TEventhandlerInterface.eventCallbackFunction(length: Cardinal;
171 events: BytePtr);
172 begin
173 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Callback'); {$ENDIF}
174 FOwner.FCriticalSection.Enter;
175 try
176 if FOwner.FResultBuffer <> nil then
177 Move(events^, FOwner.FResultBuffer^, Length);
178 finally
179 FOwner.FCriticalSection.Leave
180 end;
181 {$IFDEF EVENTDEBUG}writeln(FName,' TEventhandlerInterface: Set Event Called'); {$ENDIF}
182 {$IFDEF WINDOWS}
183 SetEvent(FEventHandler);
184 {$ELSE}
185 FEventWaiting.SetEvent;
186 {$ENDIF}
187 end;
188
189 procedure TEventhandlerInterface.WaitForEvent;
190 begin
191 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Start Event Wait'); {$ENDIF}
192 {$IFDEF WINDOWS}
193 WaitForSingleObject(FEventHandler,INFINITE);
194 {$ELSE}
195 FEventWaiting.WaitFor(INFINITE);
196 {$ENDIF}
197 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Wait Ends');{$ENDIF}
198 end;
199
200 procedure TEventhandlerInterface.CancelWait;
201 begin
202 {$IFDEF WINDOWS}
203 SetEvent(FEventHandler);
204 {$ELSE}
205 FEventWaiting.SetEvent;
206 {$ENDIF}
207 end;
208
209 { TEventHandlerThread }
210
211 procedure TEventHandlerThread.Execute;
212 begin
213 {$IFDEF EVENTDEBUG} writeln('Event Handler Thread Starts'); {$ENDIF}
214 while not Terminated do
215 begin
216 FEventHandler.WaitForEvent;
217 {$IFDEF EVENTDEBUG} writeln('Event Handler Ends Wait ',Terminated); {$ENDIF}
218 if not Terminated then
219 FOwner.EventSignaled;
220 end;
221 {$IFDEF EVENTDEBUG} writeln('Event Handler Thread Ends'); {$ENDIF}
222 end;
223
224 constructor TEventHandlerThread.Create(Owner: TFB30Events;
225 EventHandler: TEventhandlerInterface);
226 begin
227 inherited Create(false);
228 FOwner := Owner;
229 FEventHandler := EventHandler;
230 FreeOnTerminate := true;
231 end;
232
233 procedure TEventHandlerThread.Terminate;
234 begin
235 inherited Terminate;
236 FEventHandler.CancelWait;
237 {$IFDEF EVENTDEBUG} writeln('Event Handler Thread Cancelled'); {$ENDIF}
238 end;
239
240 { TFB30Events }
241
242 procedure TFB30Events.CancelEvents(Force: boolean);
243 begin
244 FCriticalSection.Enter;
245 try
246 if not FInWaitState then Exit;
247 if FEventsIntf <> nil then
248 with FFirebird30ClientAPI do
249 begin
250 FEventsIntf.Cancel(StatusIntf);
251 if not Force then
252 Check4DataBaseError;
253 end;
254 FInWaitState := false;
255 ReleaseIntf;
256 inherited CancelEvents(Force);
257 finally
258 FCriticalSection.Leave
259 end;
260 end;
261
262 function TFB30Events.GetIEvents: IEvents;
263 begin
264 Result := self;
265 end;
266
267 procedure TFB30Events.InternalAsyncWaitForEvent(EventHandler: TEventHandler;
268 EventCallBack: TEventhandlerInterface);
269 begin
270 FCriticalSection.Enter;
271 try
272 if FInWaitState then
273 IBError(ibxeInEventWait,[nil]);
274
275 FEventHandler := EventHandler;
276 ReleaseIntf;
277 with FFirebird30ClientAPI do
278 begin
279 FEventsIntf := FAttachmentIntf.queEvents(
280 StatusIntf,EventCallBack,
281 FEventBufferLen, BytePtr(FEventBuffer));
282 Check4DataBaseError;
283 end;
284 FInWaitState := true;
285
286 finally
287 FCriticalSection.Leave
288 end;
289 end;
290
291 procedure TFB30Events.ReleaseIntf;
292 begin
293 if FEventsIntf <> nil then
294 FEventsIntf.release;
295 FEventsIntf := nil;
296 end;
297
298 constructor TFB30Events.Create(DBAttachment: TFB30Attachment; Events: TStrings);
299 begin
300 inherited Create(DBAttachment,DBAttachment,Events);
301 FAttachmentIntf := DBAttachment.AttachmentIntf;
302 FFirebird30ClientAPI := DBAttachment.Firebird30ClientAPI;
303 FSyncEventCallback := TEventhandlerInterface.Create(self,'Sync');
304 FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
305 FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
306 end;
307
308 destructor TFB30Events.Destroy;
309 begin
310 CancelEvents(true);
311 if assigned(FEventHandlerThread) then
312 TEventHandlerThread(FEventHandlerThread).Terminate;
313 if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
314 if assigned(FSyncEventCallback) then TEventhandlerInterface(FSyncEventCallback).release;
315 ReleaseIntf;
316 inherited Destroy;
317 end;
318
319 procedure TFB30Events.AsyncWaitForEvent(EventHandler: TEventHandler);
320 begin
321 InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
322 end;
323
324 procedure TFB30Events.WaitForEvent;
325 begin
326 InternalAsyncWaitForEvent(nil,FSyncEventCallback);
327 FSyncEventCallback.WaitForEvent;
328 end;
329
330 end.
331

Properties

Name Value
svn:eol-style native