ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBEvents.pas
Revision: 217
Committed: Fri Mar 16 10:27:26 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/FBEvents.pas
File size: 8884 byte(s)
Log Message:
Fixes Merged

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 FBEvents;
63 tony 56 {$IFDEF MSWINDOWS}
64     {$DEFINE WINDOWS}
65     {$ENDIF}
66 tony 45
67     {$IFDEF FPC}
68 tony 56 {$mode delphi}
69 tony 45 {$interfaces COM}
70     {$ENDIF}
71    
72     interface
73    
74     uses
75     Classes, SysUtils, IB, FBClientAPI, syncobjs, FBActivityMonitor;
76    
77     type
78    
79     { TFBEvents }
80    
81     TFBEvents = class(TActivityReporter)
82     private
83     FEvents: TStringList;
84     FAttachment: IAttachment;
85 tony 47 FEventCounts: TEventCounts;
86 tony 45 protected
87 tony 56 FEventBuffer: PByte;
88 tony 45 FEventBufferLen: integer;
89 tony 56 FResultBuffer: PByte;
90 tony 45 FEventHandler: TEventHandler;
91     FCriticalSection: TCriticalSection;
92     FInWaitState: boolean;
93     procedure CreateEventBlock;
94     procedure CancelEvents(Force: boolean = false); virtual;
95     procedure EventSignaled;
96     function GetIEvents: IEvents; virtual; abstract;
97 tony 47 procedure ProcessEventCounts;
98 tony 45 public
99     constructor Create(DBAttachment: IAttachment; aMonitor: IActivityMonitor; Events: TStrings);
100     destructor Destroy; override;
101    
102     {IEvents}
103     procedure GetEvents(EventNames: TStrings);
104     procedure SetEvents(EventNames: TStrings); overload;
105 tony 56 procedure SetEvents(Event: AnsiString); overload;
106 tony 45 procedure Cancel;
107     function ExtractEventCounts: TEventCounts;
108     function GetAttachment: IAttachment;
109 tony 47 procedure AsyncWaitForEvent(EventHandler: TEventHandler); virtual; abstract;
110 tony 45 end;
111    
112    
113     implementation
114    
115     uses FBMessages, IBExternals;
116    
117     const
118     MaxEvents = 15;
119    
120     { TFBEvents }
121    
122     procedure TFBEvents.CreateEventBlock;
123     var
124     i: integer;
125 tony 56 EventNames: array of PAnsiChar;
126     EventName: AnsiString;
127 tony 45 begin
128     with FirebirdClientAPI do
129     begin
130     if FEventBuffer <> nil then
131     isc_free( FEventBuffer);
132     FEventBuffer := nil;
133     if FResultBuffer <> nil then
134     isc_free( FResultBuffer);
135     FResultBuffer := nil;
136    
137     setlength(EventNames,MaxEvents);
138     try
139     for i := 0 to FEvents.Count-1 do
140 tony 56 begin
141 tony 217 EventName := FEvents[i];
142 tony 56 EventNames[i] := PAnsiChar(EventName);
143     end;
144 tony 45
145     FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
146     FEvents.Count,
147     EventNames[0],EventNames[1],EventNames[2],
148     EventNames[3],EventNames[4],EventNames[5],
149     EventNames[6],EventNames[7],EventNames[8],
150     EventNames[9],EventNames[10],EventNames[11],
151     EventNames[12],EventNames[13],EventNames[14]
152     );
153     finally
154     SetLength(EventNames,0)
155     end;
156     end;
157     end;
158    
159     procedure TFBEvents.CancelEvents(Force: boolean);
160     begin
161     FEventHandler := nil;
162     end;
163    
164     procedure TFBEvents.EventSignaled;
165     var Handler: TEventHandler;
166     begin
167 tony 47 Handler := nil;
168 tony 45 FCriticalSection.Enter;
169     try
170     if not FInWaitState then Exit;
171     FInWaitState := false;
172 tony 47 ProcessEventCounts;
173 tony 45 if assigned(FEventHandler) then
174     begin
175     Handler := FEventHandler;
176     FEventHandler := nil;
177     end;
178     finally
179 tony 47 FCriticalSection.Leave;
180 tony 45 end;
181 tony 47 if assigned(Handler) then
182     Handler(GetIEvents);
183 tony 45 end;
184    
185 tony 47 procedure TFBEvents.ProcessEventCounts;
186     var P: PISC_LONG;
187     EventCountList: array[0..19] of ISC_LONG;
188     i: integer;
189     j: integer;
190     begin
191     SetLength(FEventCounts,0);
192     if FResultBuffer = nil then Exit;
193    
194     FillChar(EventCountList,sizeof(EventCountList),0);
195    
196     with FirebirdClientAPI do
197     isc_event_counts( @EventCountList, FEventBufferLen, FEventBuffer, FResultBuffer);
198     j := 0;
199 tony 56 P := @EventCountList;
200 tony 47 for i := 0 to FEvents.Count - 1 do
201     begin
202     if EventCountList[i] <> 0 then
203     begin
204     Inc(j);
205     SetLength(FEventCounts,j);
206     FEventCounts[j-1].EventName := FEvents[i];
207     FEventCounts[j-1].Count := P^;
208     Inc(P);
209     // writeln('Event: ',FEventCounts[j-1].EventName,' Count = ',FEventCounts[j-1].Count);
210     end;
211     end;
212     end;
213    
214 tony 45 constructor TFBEvents.Create(DBAttachment: IAttachment;
215     aMonitor: IActivityMonitor; Events: TStrings);
216     begin
217     inherited Create(aMonitor);
218     FAttachment := DBAttachment;
219     if Events.Count > MaxEvents then
220     IBError(ibxeMaximumEvents, [nil]);
221    
222     FCriticalSection := TCriticalSection.Create;
223     FEvents := TStringList.Create;
224     FEvents.Assign(Events);
225     CreateEventBlock;
226     end;
227    
228     destructor TFBEvents.Destroy;
229     begin
230     if assigned(FCriticalSection) then FCriticalSection.Free;
231     if assigned(FEvents) then FEvents.Free;
232     with FirebirdClientAPI do
233     begin
234     if FEventBuffer <> nil then
235     isc_free( FEventBuffer);
236     if FResultBuffer <> nil then
237     isc_free( FResultBuffer);
238     end;
239     inherited Destroy;
240     end;
241    
242     procedure TFBEvents.GetEvents(EventNames: TStrings);
243     begin
244     EventNames.Assign(FEvents)
245     end;
246    
247     procedure TFBEvents.SetEvents(EventNames: TStrings);
248     begin
249 tony 217 if (EventNames.Count > 0) and not IsMultiThread then
250     IBError(ibxMultiThreadRequired,['Firebird Events Handling']);
251 tony 45 if EventNames.Text <> FEvents.Text then
252     begin
253     Cancel;
254     FEvents.Assign(EventNames);
255     CreateEventBlock;
256     end;
257     end;
258    
259 tony 56 procedure TFBEvents.SetEvents(Event: AnsiString);
260 tony 45 var S: TStringList;
261     begin
262     S := TStringList.Create;
263     try
264     S.Add(Event);
265     SetEvents(S);
266     finally
267     S.Free;
268     end;
269     end;
270    
271     procedure TFBEvents.Cancel;
272     begin
273     if assigned(FEventHandler) then
274     CancelEvents;
275     end;
276    
277     function TFBEvents.ExtractEventCounts: TEventCounts;
278     begin
279 tony 47 Result := FEventCounts;
280 tony 45 end;
281    
282     function TFBEvents.GetAttachment: IAttachment;
283     begin
284     Result := FAttachment;
285     end;
286    
287     end.
288