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 |
|