ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBEvents.pas
Revision: 45
Committed: Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type: text/x-pascal
File size: 8262 byte(s)
Log Message:
Committing updates for Release R2-0-0

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