ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/2.5/FB25Events.pas
Revision: 381
Committed: Sat Jan 15 00:06:22 2022 UTC (3 days, 17 hours ago) by tony
File size: 10048 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. Although predominantly
4 * a new development they include source code taken from IBX and may be
5 * considered a derived product. This software thus also includes the copyright
6 * notice and license conditions from IBX.
7 *
8 * Except for those parts dervied from IBX, contents of this file are subject
9 * to the Initial Developer's Public License Version 1.0 (the "License"); you
10 * may not use this file except in compliance with the License. You may obtain a
11 * copy of the License here:
12 *
13 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
14 *
15 * Software distributed under the License is distributed on an "AS
16 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
17 * implied. See the License for the specific language governing rights
18 * and limitations under the License.
19 *
20 * The Initial Developer of the Original Code is Tony Whyman.
21 *
22 * The Original Code is (C) 2016 Tony Whyman, MWA Software
23 * (http://www.mwasoftware.co.uk).
24 *
25 * All Rights Reserved.
26 *
27 * Contributor(s): ______________________________________.
28 *
29 *)
30 {************************************************************************}
31 { }
32 { Borland Delphi Visual Component Library }
33 { InterBase Express core components }
34 { }
35 { Copyright (c) 1998-2000 Inprise Corporation }
36 { }
37 { InterBase Express is based in part on the product }
38 { Free IB Components, written by Gregory H. Deatz for }
39 { Hoagland, Longo, Moran, Dunst & Doukas Company. }
40 { Free IB Components is used under license. }
41 { }
42 { The contents of this file are subject to the InterBase }
43 { Public License Version 1.0 (the "License"); you may not }
44 { use this file except in compliance with the License. You }
45 { may obtain a copy of the License at http://www.Inprise.com/IPL.html }
46 { Software distributed under the License is distributed on }
47 { an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
48 { express or implied. See the License for the specific language }
49 { governing rights and limitations under the License. }
50 { The Original Code was created by InterBase Software Corporation }
51 { and its successors. }
52 { Portions created by Inprise Corporation are Copyright (C) Inprise }
53 { Corporation. All Rights Reserved. }
54 { Contributor(s): Jeff Overcash }
55 { }
56 { IBX For Lazarus (Firebird Express) }
57 { Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
58 { Portions created by MWA Software are copyright McCallum Whyman }
59 { Associates Ltd 2011 - 2015 }
60 { }
61 {************************************************************************}
62 unit FB25Events;
63 {$IFDEF MSWINDOWS}
64 {$DEFINE WINDOWS}
65 {$ENDIF}
66
67 {$IFDEF FPC}
68 {$mode delphi}
69 {$interfaces COM}
70 {$ENDIF}
71
72 interface
73
74 uses
75 {$IFDEF WINDOWS}Windows, {$ENDIF}Classes, SysUtils, IB, FB25ClientAPI, FB25Attachment,
76 IBExternals, IBHeader, syncobjs, FBEvents;
77
78 type
79 TFB25Events = class;
80
81 { TEventhandlerInterface }
82
83 TEventhandlerInterface = class
84 private
85 FOwner: TFB25Events;
86 {$IFDEF WINDOWS}
87 {Make direct use of Windows API as TEventObject don't seem to work under
88 Windows!}
89 FEventHandler: THandle;
90 {$ELSE}
91 FEventWaiting: TEventObject;
92 {$ENDIF}
93 public
94 constructor Create(aOwner: TFB25Events);
95 destructor Destroy; override;
96 procedure eventCallbackFunction(length: short; updated: PAnsiChar);
97 procedure WaitForEvent;
98 procedure CancelWait;
99 end;
100
101 { TFB25Events }
102
103 TFB25Events = class(TFBEvents,IEvents)
104 private
105 FEventID: ISC_LONG;
106 FDBHandle: TISC_DB_HANDLE;
107 FEventHandlerThread: TObject;
108 FAsyncEventCallback: TEventhandlerInterface;
109 FFirebird25ClientAPI: TFB25ClientAPI;
110 protected
111 procedure CancelEvents(Force: boolean = false); override;
112 function GetIEvents: IEvents; override;
113 public
114 constructor Create(DBAttachment: TFB25Attachment; Events: TStrings);
115 destructor Destroy; override;
116
117 {IEvents}
118 procedure WaitForEvent; override;
119 procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
120 end;
121
122 implementation
123
124 uses FBMessages;
125
126 type
127
128 { TEventHandlerThread }
129
130 TEventHandlerThread = class(TThread)
131 private
132 FOwner: TFB25Events;
133 FEventHandler: TEventhandlerInterface;
134 protected
135 procedure Execute; override;
136 public
137 constructor Create(Owner: TFB25Events; EventHandler: TEventhandlerInterface);
138 procedure Terminate;
139 end;
140
141 { TEventHandlerThread }
142
143 procedure TEventHandlerThread.Execute;
144 begin
145 while not Terminated do
146 begin
147 FEventHandler.WaitForEvent;
148
149 if not Terminated then
150 FOwner.EventSignaled;
151 end;
152 end;
153
154 constructor TEventHandlerThread.Create(Owner: TFB25Events;
155 EventHandler: TEventhandlerInterface);
156 begin
157 inherited Create(false);
158 FOwner := Owner;
159 FEventHandler := EventHandler;
160 FreeOnTerminate := true;
161 end;
162
163 procedure TEventHandlerThread.Terminate;
164 begin
165 inherited Terminate;
166 FEventHandler.CancelWait;
167 end;
168
169 {This procedure is used for the event call back - note the cdecl }
170
171 procedure IBEventCallback( ptr: pointer; length: short; updated: PAnsiChar); cdecl;
172 begin
173 if (ptr = nil) or (length = 0) or (updated = nil) then
174 Exit;
175 { Handle events asynchronously in second thread }
176 TEventhandlerInterface(ptr).eventCallbackFunction(length,updated);
177 end;
178
179 { TEventhandlerInterface }
180
181 constructor TEventhandlerInterface.Create(aOwner: TFB25Events);
182 var
183 PSa : PSecurityAttributes;
184 {$IFDEF WINDOWS}
185 Sd : TSecurityDescriptor;
186 Sa : TSecurityAttributes;
187 begin
188 InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
189 SetSecurityDescriptorDacl(@Sd,true,nil,false);
190 Sa.nLength := SizeOf(Sa);
191 Sa.lpSecurityDescriptor := @Sd;
192 Sa.bInheritHandle := true;
193 PSa := @Sa;
194 {$ELSE}
195 GUID : TGUID;
196 begin
197 PSa:= nil;
198 {$ENDIF}
199 inherited Create;
200 {$IFDEF WINDOWS}
201 FEventHandler := CreateEvent(PSa,false,false,nil);
202 {$ELSE}
203 CreateGuid(GUID);
204 FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
205 {$ENDIF}
206 FOWner := aOwner;
207 end;
208
209 destructor TEventhandlerInterface.Destroy;
210 begin
211 {$IFDEF WINDOWS}
212 CloseHandle(FEventHandler);
213 {$ELSE}
214 if assigned(FEventWaiting) then FEventWaiting.Free;
215 {$ENDIF}
216 inherited Destroy;
217 end;
218
219 procedure TEventhandlerInterface.eventCallbackFunction(length: short;
220 updated: PAnsiChar);
221 begin
222 FOwner.FCriticalSection.Enter;
223 try
224 if FOwner.FResultBuffer <> nil then
225 Move(updated[0], FOwner.FResultBuffer[0], length);
226 finally
227 FOwner.FCriticalSection.Leave
228 end;
229 // writeln('Set Event');
230 {$IFDEF WINDOWS}
231 SetEvent(FEventHandler);
232 {$ELSE}
233 FEventWaiting.SetEvent;
234 {$ENDIF}
235 end;
236
237 procedure TEventhandlerInterface.WaitForEvent;
238 begin
239 {$IFDEF WINDOWS}
240 WaitForSingleObject(FEventHandler,INFINITE);
241 {$ELSE}
242 FEventWaiting.WaitFor(INFINITE);
243 {$ENDIF}
244 // writeln('Event Wait Ends');
245 end;
246
247 procedure TEventhandlerInterface.CancelWait;
248 begin
249 {$IFDEF WINDOWS}
250 SetEvent(FEventHandler);
251 {$ELSE}
252 FEventWaiting.SetEvent;
253 {$ENDIF}
254 end;
255
256
257 { TFB25Events }
258
259 procedure TFB25Events.CancelEvents(Force: boolean);
260 begin
261 FCriticalSection.Enter;
262 try
263 if not FInWaitState then Exit;
264 with FFirebird25ClientAPI do
265 if (Call(isc_Cancel_events( StatusVector, @FDBHandle, @FEventID),false) > 0) and not Force then
266 IBDatabaseError;
267
268 FInWaitState := false;
269 inherited CancelEvents(Force);
270 finally
271 FCriticalSection.Leave
272 end;
273 end;
274
275 function TFB25Events.GetIEvents: IEvents;
276 begin
277 Result := self;
278 end;
279
280 constructor TFB25Events.Create(DBAttachment: TFB25Attachment; Events: TStrings);
281 begin
282 inherited Create(DBAttachment,DBAttachment,Events);
283 FDBHandle := DBAttachment.Handle;
284 FFirebird25ClientAPI := DBAttachment.Firebird25ClientAPI;
285 OnDatabaseError := FFirebird25ClientAPI.IBDataBaseError;
286 FAsyncEventCallback := TEventhandlerInterface.Create(self);
287 FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
288 end;
289
290 destructor TFB25Events.Destroy;
291 begin
292 CancelEvents(true);
293 if assigned(FEventHandlerThread) then
294 TEventHandlerThread(FEventHandlerThread).Terminate;
295 if assigned(FAsyncEventCallback) then
296 TEventhandlerInterface(FAsyncEventCallback).Free;
297 inherited Destroy;
298 end;
299
300 procedure TFB25Events.AsyncWaitForEvent(EventHandler: TEventHandler);
301 var callback: pointer;
302 begin
303 FCriticalSection.Enter;
304 try
305 if FInWaitState then
306 IBError(ibxeInEventWait,[nil]);
307
308 FEventHandler := EventHandler;
309 callback := @IBEventCallback;
310 with FFirebird25ClientAPI do
311 Call(isc_que_events( StatusVector, @FDBHandle, @FEventID, FEventBufferLen,
312 FEventBuffer, TISC_CALLBACK(callback), PVoid(FAsyncEventCallback)));
313 FInWaitState := true;
314 finally
315 FCriticalSection.Leave
316 end;
317 end;
318
319 procedure TFB25Events.WaitForEvent;
320 begin
321 if FInWaitState then
322 IBError(ibxeInEventWait,[nil]);
323
324 FInWaitState := true;
325 try
326 with FFirebird25ClientAPI do
327 Call(isc_wait_for_event(StatusVector,@FDBHandle, FEventBufferlen,FEventBuffer,FResultBuffer));
328 finally
329 FInWaitState := false;
330 end;
331 end;
332
333 end.
334

Properties

Name Value
svn:eol-style native