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: 216
Committed: Thu Mar 15 17:21:13 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/2.5/FB25Events.pas
File size: 9874 byte(s)
Log Message:
Fixes Merged

File Contents

# Content
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 protected
110 procedure CancelEvents(Force: boolean = false); override;
111 function GetIEvents: IEvents; override;
112 public
113 constructor Create(DBAttachment: TFB25Attachment; Events: TStrings);
114 destructor Destroy; override;
115
116 {IEvents}
117 procedure WaitForEvent;
118 procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
119 end;
120
121 implementation
122
123 uses FBMessages;
124
125 type
126
127 { TEventHandlerThread }
128
129 TEventHandlerThread = class(TThread)
130 private
131 FOwner: TFB25Events;
132 FEventHandler: TEventhandlerInterface;
133 protected
134 procedure Execute; override;
135 public
136 constructor Create(Owner: TFB25Events; EventHandler: TEventhandlerInterface);
137 procedure Terminate;
138 end;
139
140 { TEventHandlerThread }
141
142 procedure TEventHandlerThread.Execute;
143 begin
144 while not Terminated do
145 begin
146 FEventHandler.WaitForEvent;
147
148 if not Terminated then
149 FOwner.EventSignaled;
150 end;
151 end;
152
153 constructor TEventHandlerThread.Create(Owner: TFB25Events;
154 EventHandler: TEventhandlerInterface);
155 begin
156 inherited Create(false);
157 FOwner := Owner;
158 FEventHandler := EventHandler;
159 FreeOnTerminate := true;
160 end;
161
162 procedure TEventHandlerThread.Terminate;
163 begin
164 inherited Terminate;
165 FEventHandler.CancelWait;
166 end;
167
168 {This procedure is used for the event call back - note the cdecl }
169
170 procedure IBEventCallback( ptr: pointer; length: short; updated: PAnsiChar); cdecl;
171 begin
172 if (ptr = nil) or (length = 0) or (updated = nil) then
173 Exit;
174 { Handle events asynchronously in second thread }
175 TEventhandlerInterface(ptr).eventCallbackFunction(length,updated);
176 end;
177
178 { TEventhandlerInterface }
179
180 constructor TEventhandlerInterface.Create(aOwner: TFB25Events);
181 var
182 PSa : PSecurityAttributes;
183 {$IFDEF WINDOWS}
184 Sd : TSecurityDescriptor;
185 Sa : TSecurityAttributes;
186 begin
187 InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
188 SetSecurityDescriptorDacl(@Sd,true,nil,false);
189 Sa.nLength := SizeOf(Sa);
190 Sa.lpSecurityDescriptor := @Sd;
191 Sa.bInheritHandle := true;
192 PSa := @Sa;
193 {$ELSE}
194 GUID : TGUID;
195 begin
196 PSa:= nil;
197 {$ENDIF}
198 inherited Create;
199 {$IFDEF WINDOWS}
200 FEventHandler := CreateEvent(PSa,false,false,nil);
201 {$ELSE}
202 CreateGuid(GUID);
203 FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
204 {$ENDIF}
205 FOWner := aOwner;
206 end;
207
208 destructor TEventhandlerInterface.Destroy;
209 begin
210 {$IFDEF WINDOWS}
211 CloseHandle(FEventHandler);
212 {$ELSE}
213 if assigned(FEventWaiting) then FEventWaiting.Free;
214 {$ENDIF}
215 inherited Destroy;
216 end;
217
218 procedure TEventhandlerInterface.eventCallbackFunction(length: short;
219 updated: PAnsiChar);
220 begin
221 FOwner.FCriticalSection.Enter;
222 try
223 if FOwner.FResultBuffer <> nil then
224 Move(updated[0], FOwner.FResultBuffer[0], length);
225 finally
226 FOwner.FCriticalSection.Leave
227 end;
228 // writeln('Set Event');
229 {$IFDEF WINDOWS}
230 SetEvent(FEventHandler);
231 {$ELSE}
232 FEventWaiting.SetEvent;
233 {$ENDIF}
234 end;
235
236 procedure TEventhandlerInterface.WaitForEvent;
237 begin
238 {$IFDEF WINDOWS}
239 WaitForSingleObject(FEventHandler,INFINITE);
240 {$ELSE}
241 FEventWaiting.WaitFor(INFINITE);
242 {$ENDIF}
243 // writeln('Event Wait Ends');
244 end;
245
246 procedure TEventhandlerInterface.CancelWait;
247 begin
248 {$IFDEF WINDOWS}
249 SetEvent(FEventHandler);
250 {$ELSE}
251 FEventWaiting.SetEvent;
252 {$ENDIF}
253 end;
254
255
256 { TFB25Events }
257
258 procedure TFB25Events.CancelEvents(Force: boolean);
259 begin
260 FCriticalSection.Enter;
261 try
262 if not FInWaitState then Exit;
263 with Firebird25ClientAPI do
264 if (Call(isc_Cancel_events( StatusVector, @FDBHandle, @FEventID),false) > 0) and not Force then
265 IBDatabaseError;
266
267 FInWaitState := false;
268 inherited CancelEvents(Force);
269 finally
270 FCriticalSection.Leave
271 end;
272 end;
273
274 function TFB25Events.GetIEvents: IEvents;
275 begin
276 Result := self;
277 end;
278
279 constructor TFB25Events.Create(DBAttachment: TFB25Attachment; Events: TStrings);
280 begin
281 inherited Create(DBAttachment,DBAttachment,Events);
282 FDBHandle := DBAttachment.Handle;
283 FAsyncEventCallback := TEventhandlerInterface.Create(self);
284 FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
285 end;
286
287 destructor TFB25Events.Destroy;
288 begin
289 CancelEvents(true);
290 if assigned(FEventHandlerThread) then
291 TEventHandlerThread(FEventHandlerThread).Terminate;
292 if assigned(FAsyncEventCallback) then
293 TEventhandlerInterface(FAsyncEventCallback).Free;
294 inherited Destroy;
295 end;
296
297 procedure TFB25Events.AsyncWaitForEvent(EventHandler: TEventHandler);
298 var callback: pointer;
299 begin
300 FCriticalSection.Enter;
301 try
302 if FInWaitState then
303 IBError(ibxeInEventWait,[nil]);
304
305 FEventHandler := EventHandler;
306 callback := @IBEventCallback;
307 with Firebird25ClientAPI do
308 Call(isc_que_events( StatusVector, @FDBHandle, @FEventID, FEventBufferLen,
309 FEventBuffer, TISC_CALLBACK(callback), PVoid(FAsyncEventCallback)));
310 FInWaitState := true;
311 finally
312 FCriticalSection.Leave
313 end;
314 end;
315
316 procedure TFB25Events.WaitForEvent;
317 begin
318 if FInWaitState then
319 IBError(ibxeInEventWait,[nil]);
320
321 FInWaitState := true;
322 try
323 with Firebird25ClientAPI do
324 Call(isc_wait_for_event(StatusVector,@FDBHandle, FEventBufferlen,FEventBuffer,FResultBuffer));
325 finally
326 FInWaitState := false;
327 end;
328 end;
329
330 end.
331