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: 379
Committed: Mon Jan 10 10:08:03 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 9084 byte(s)
Log Message:
set line ending property

File Contents

# User Rev Content
1 tony 45 (*
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 tony 56 {$IFDEF MSWINDOWS}
29     {$DEFINE WINDOWS}
30     {$ENDIF}
31 tony 45
32     {$IFDEF FPC}
33 tony 56 {$mode delphi}
34 tony 45 {$interfaces COM}
35     {$ENDIF}
36    
37 tony 217 { $DEFINE EVENTDEBUG}
38    
39 tony 45 interface
40    
41     uses
42     {$IFDEF WINDOWS}Windows, {$ENDIF} Classes, SysUtils, Firebird, IB, FB30ClientAPI, FB30Attachment,
43 tony 216 syncobjs, FBEvents;
44 tony 45
45     type
46     TFB30Events = class;
47    
48     { TEventhandlerInterface }
49    
50     TEventhandlerInterface = class(Firebird.IEventCallbackImpl)
51     private
52     FOwner: TFB30Events;
53 tony 56 FName: AnsiString;
54 tony 45 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 tony 56 constructor Create(aOwner: TFB30Events; aName: AnsiString);
64 tony 45 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 tony 263 FFirebird30ClientAPI: TFB30ClientAPI;
82 tony 45 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;
93 tony 47 procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
94 tony 45 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 tony 56 constructor TEventhandlerInterface.Create(aOwner: TFB30Events; aName: AnsiString);
115 tony 45 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 tony 47 FEventHandler := CreateEvent(PSa,false,false,nil);
135 tony 45 {$ELSE}
136     CreateGuid(GUID);
137     FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
138     {$ENDIF}
139     FOWner := aOwner;
140     FName := aName;
141     addRef;
142 tony 217 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Create'); {$ENDIF}
143 tony 45 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 tony 217 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Destroy'); {$ENDIF}
153 tony 45 inherited Destroy;
154     end;
155    
156     procedure TEventhandlerInterface.addRef;
157     begin
158     Inc(FRef);
159 tony 217 {$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
160 tony 45 end;
161    
162     function TEventhandlerInterface.release: Integer;
163     begin
164     Dec(FRef);
165 tony 217 {$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
166 tony 45 if FRef = 0 then Free;
167     Result := FRef;
168     end;
169    
170     procedure TEventhandlerInterface.eventCallbackFunction(length: Cardinal;
171     events: BytePtr);
172     begin
173 tony 217 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Callback'); {$ENDIF}
174 tony 45 FOwner.FCriticalSection.Enter;
175     try
176     if FOwner.FResultBuffer <> nil then
177 tony 56 Move(events^, FOwner.FResultBuffer^, Length);
178 tony 45 finally
179     FOwner.FCriticalSection.Leave
180     end;
181 tony 217 {$IFDEF EVENTDEBUG}writeln(FName,' TEventhandlerInterface: Set Event Called'); {$ENDIF}
182 tony 47 {$IFDEF WINDOWS}
183     SetEvent(FEventHandler);
184     {$ELSE}
185     FEventWaiting.SetEvent;
186     {$ENDIF}
187 tony 45 end;
188    
189     procedure TEventhandlerInterface.WaitForEvent;
190     begin
191 tony 217 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Start Event Wait'); {$ENDIF}
192 tony 45 {$IFDEF WINDOWS}
193     WaitForSingleObject(FEventHandler,INFINITE);
194     {$ELSE}
195     FEventWaiting.WaitFor(INFINITE);
196     {$ENDIF}
197 tony 217 {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Wait Ends');{$ENDIF}
198 tony 45 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 tony 217 {$IFDEF EVENTDEBUG} writeln('Event Handler Thread Starts'); {$ENDIF}
214 tony 45 while not Terminated do
215     begin
216     FEventHandler.WaitForEvent;
217 tony 217 {$IFDEF EVENTDEBUG} writeln('Event Handler Ends Wait ',Terminated); {$ENDIF}
218 tony 45
219     if not Terminated then
220     FOwner.EventSignaled;
221     end;
222 tony 217 {$IFDEF EVENTDEBUG} writeln('Event Handler Thread Ends'); {$ENDIF}
223 tony 45 end;
224    
225     constructor TEventHandlerThread.Create(Owner: TFB30Events;
226     EventHandler: TEventhandlerInterface);
227     begin
228 tony 56 inherited Create(false);
229 tony 45 FOwner := Owner;
230     FEventHandler := EventHandler;
231     FreeOnTerminate := true;
232     end;
233    
234     procedure TEventHandlerThread.Terminate;
235     begin
236     inherited Terminate;
237     FEventHandler.CancelWait;
238 tony 217 {$IFDEF EVENTDEBUG} writeln('Event Handler Thread Cancelled'); {$ENDIF}
239 tony 45 end;
240    
241     { TFB30Events }
242    
243     procedure TFB30Events.CancelEvents(Force: boolean);
244     begin
245     FCriticalSection.Enter;
246     try
247     if not FInWaitState then Exit;
248     if FEventsIntf <> nil then
249 tony 263 with FFirebird30ClientAPI do
250 tony 45 begin
251     FEventsIntf.Cancel(StatusIntf);
252     if not Force then
253     Check4DataBaseError;
254     end;
255     FInWaitState := false;
256     ReleaseIntf;
257     inherited CancelEvents(Force);
258     finally
259     FCriticalSection.Leave
260     end;
261     end;
262    
263     function TFB30Events.GetIEvents: IEvents;
264     begin
265     Result := self;
266     end;
267    
268     procedure TFB30Events.InternalAsyncWaitForEvent(EventHandler: TEventHandler;
269     EventCallBack: TEventhandlerInterface);
270     begin
271     FCriticalSection.Enter;
272     try
273     if FInWaitState then
274     IBError(ibxeInEventWait,[nil]);
275    
276     FEventHandler := EventHandler;
277     ReleaseIntf;
278 tony 263 with FFirebird30ClientAPI do
279 tony 45 begin
280     FEventsIntf := FAttachmentIntf.queEvents(
281     StatusIntf,EventCallBack,
282     FEventBufferLen, BytePtr(FEventBuffer));
283     Check4DataBaseError;
284     end;
285     FInWaitState := true;
286    
287     finally
288     FCriticalSection.Leave
289     end;
290     end;
291    
292     procedure TFB30Events.ReleaseIntf;
293     begin
294     if FEventsIntf <> nil then
295     FEventsIntf.release;
296     FEventsIntf := nil;
297     end;
298    
299     constructor TFB30Events.Create(DBAttachment: TFB30Attachment; Events: TStrings);
300     begin
301     inherited Create(DBAttachment,DBAttachment,Events);
302     FAttachmentIntf := DBAttachment.AttachmentIntf;
303 tony 263 FFirebird30ClientAPI := DBAttachment.Firebird30ClientAPI;
304 tony 45 FSyncEventCallback := TEventhandlerInterface.Create(self,'Sync');
305     end;
306    
307     destructor TFB30Events.Destroy;
308     begin
309     CancelEvents(true);
310     if assigned(FEventHandlerThread) then
311     TEventHandlerThread(FEventHandlerThread).Terminate;
312     if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
313     if assigned(FSyncEventCallback) then TEventhandlerInterface(FSyncEventCallback).release;
314     ReleaseIntf;
315     inherited Destroy;
316     end;
317    
318     procedure TFB30Events.AsyncWaitForEvent(EventHandler: TEventHandler);
319     begin
320 tony 47 {Seems like we have to create a new callback object each time to avoid empty events}
321     if assigned(FEventHandlerThread) then
322     TEventHandlerThread(FEventHandlerThread).Terminate;
323     if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
324     FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
325     FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
326 tony 45 InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
327     end;
328    
329     procedure TFB30Events.WaitForEvent;
330     begin
331     InternalAsyncWaitForEvent(nil,FSyncEventCallback);
332     FSyncEventCallback.WaitForEvent;
333     end;
334    
335     end.
336    

Properties

Name Value
svn:eol-style native