ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBEvents.pas
Revision: 263
Committed: Thu Dec 6 15:55:01 2018 UTC (5 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 9022 byte(s)
Log Message:
Release 2.3.2 committed

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