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: 215
Committed: Thu Mar 15 16:25:03 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/2.5/FB25Events.pas
File size: 9932 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 {$IF defined(FPC) and defined(UNIX)} ,cthreads {$IFEND};
78
79 type
80 TFB25Events = class;
81
82 { TEventhandlerInterface }
83
84 TEventhandlerInterface = class
85 private
86 FOwner: TFB25Events;
87 {$IFDEF WINDOWS}
88 {Make direct use of Windows API as TEventObject don't seem to work under
89 Windows!}
90 FEventHandler: THandle;
91 {$ELSE}
92 FEventWaiting: TEventObject;
93 {$ENDIF}
94 public
95 constructor Create(aOwner: TFB25Events);
96 destructor Destroy; override;
97 procedure eventCallbackFunction(length: short; updated: PAnsiChar);
98 procedure WaitForEvent;
99 procedure CancelWait;
100 end;
101
102 { TFB25Events }
103
104 TFB25Events = class(TFBEvents,IEvents)
105 private
106 FEventID: ISC_LONG;
107 FDBHandle: TISC_DB_HANDLE;
108 FEventHandlerThread: TObject;
109 FAsyncEventCallback: TEventhandlerInterface;
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;
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 Firebird25ClientAPI 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 FAsyncEventCallback := TEventhandlerInterface.Create(self);
285 FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
286 end;
287
288 destructor TFB25Events.Destroy;
289 begin
290 CancelEvents(true);
291 if assigned(FEventHandlerThread) then
292 TEventHandlerThread(FEventHandlerThread).Terminate;
293 if assigned(FAsyncEventCallback) then
294 TEventhandlerInterface(FAsyncEventCallback).Free;
295 inherited Destroy;
296 end;
297
298 procedure TFB25Events.AsyncWaitForEvent(EventHandler: TEventHandler);
299 var callback: pointer;
300 begin
301 FCriticalSection.Enter;
302 try
303 if FInWaitState then
304 IBError(ibxeInEventWait,[nil]);
305
306 FEventHandler := EventHandler;
307 callback := @IBEventCallback;
308 with Firebird25ClientAPI do
309 Call(isc_que_events( StatusVector, @FDBHandle, @FEventID, FEventBufferLen,
310 FEventBuffer, TISC_CALLBACK(callback), PVoid(FAsyncEventCallback)));
311 FInWaitState := true;
312 finally
313 FCriticalSection.Leave
314 end;
315 end;
316
317 procedure TFB25Events.WaitForEvent;
318 begin
319 if FInWaitState then
320 IBError(ibxeInEventWait,[nil]);
321
322 FInWaitState := true;
323 try
324 with Firebird25ClientAPI do
325 Call(isc_wait_for_event(StatusVector,@FDBHandle, FEventBufferlen,FEventBuffer,FResultBuffer));
326 finally
327 FInWaitState := false;
328 end;
329 end;
330
331 end.
332