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: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/2.5/FB25Events.pas
File size: 9828 byte(s)
Log Message:
Committing updates for Release R2-0-1

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