ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBEvents.pas
Revision: 375
Committed: Sun Jan 9 23:42:58 2022 UTC (2 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 12416 byte(s)
Log Message:
Fixes

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 {Firebird Event and Result buffer syntax is:
82
83 record
84 version: byte;
85 event: array of packed record
86 strlen: byte;
87 strchars: array of AnsiChar; //no of chars given by strlen
88 EventCounts: long;
89 end;
90 end;
91
92 }
93
94 TFBEvents = class(TActivityReporter)
95 private
96 FEvents: TStringList;
97 FAttachment: IAttachment;
98 FEventCounts: TEventCounts;
99 FFirebirdClientAPI: TFBClientAPI;
100 protected
101 FEventBuffer: PByte;
102 FEventBufferLen: integer;
103 FResultBuffer: PByte;
104 FEventHandler: TEventHandler;
105 FCriticalSection: TCriticalSection;
106 FInWaitState: boolean;
107 procedure CreateEventBlock;
108 procedure CancelEvents(Force: boolean = false); virtual;
109 procedure EventSignaled;
110 function GetIEvents: IEvents; virtual; abstract;
111 procedure ProcessEventCounts;
112 public
113 const EPB_version1 = 1;
114 public
115 constructor Create(DBAttachment: IAttachment; aMonitor: IActivityMonitor; Events: TStrings);
116 destructor Destroy; override;
117
118 {IEvents}
119 procedure GetEvents(EventNames: TStrings);
120 procedure SetEvents(EventNames: TStrings); overload;
121 procedure SetEvents(Event: AnsiString); overload;
122 procedure Cancel;
123 function ExtractEventCounts: TEventCounts;
124 function GetAttachment: IAttachment;
125 procedure AsyncWaitForEvent(EventHandler: TEventHandler); virtual; abstract;
126 end;
127
128
129 implementation
130
131 uses FBMessages, IBExternals;
132
133 const
134 MaxEvents = 15;
135
136 { TFBEvents }
137
138 (* Original Firebird 'C' code
139
140 SLONG API_ROUTINE_VARARG isc_event_block(UCHAR** event_buffer,
141 UCHAR** result_buffer,
142 USHORT count, ...)
143 {
144 /**************************************
145 *
146 * i s c _ e v e n t _ b l o c k
147 *
148 **************************************
149 *
150 * Functional description
151 * Create an initialized event parameter block from a
152 * variable number of input arguments.
153 * Return the size of the block.
154 *
155 * Return 0 if any error occurs.
156 *
157 **************************************/
158 va_list ptr;
159
160 va_start(ptr, count);
161
162 // calculate length of event parameter block, setting initial length to include version
163 // and counts for each argument
164
165 SLONG length = 1;
166 USHORT i = count;
167 while (i--)
168 {
169 const char* q = va_arg(ptr, SCHAR * );
170 length += static_cast<SLONG>(strlen(q)) + 5;
171 }
172 va_end(ptr);
173
174 UCHAR* p = *event_buffer = (UCHAR * ) gds__alloc((SLONG) length);
175 // FREE: apparently never freed
176 if (!*event_buffer) // NOMEM:
177 return 0;
178 if ((*result_buffer = (UCHAR * ) gds__alloc((SLONG) length)) == NULL)
179 {
180 // NOMEM:
181 // FREE: apparently never freed
182 gds__free(*event_buffer);
183 *event_buffer = NULL;
184 return 0;
185 }
186
187 // initialize the block with event names and counts
188
189 *p++ = EPB_version1;
190
191 va_start(ptr, count);
192
193 i = count;
194 while (i--)
195 {
196 const char* q = va_arg(ptr, SCHAR * );
197
198 // Strip the blanks from the ends
199 const char* end = q + strlen(q);
200 while (--end >= q && *end == ' ')
201 ;
202 *p++ = end - q + 1;
203 while (q <= end)
204 *p++ = *q++;
205 *p++ = 0;
206 *p++ = 0;
207 *p++ = 0;
208 *p++ = 0;
209 }
210 va_end(ptr);
211
212 return static_cast<SLONG>(p - *event_buffer);
213 }
214 *)
215
216 {CreateEventBlock effectively replaces isc_event_block}
217
218 procedure TFBEvents.CreateEventBlock;
219 var i: integer;
220 P: PByte;
221 begin
222 {calculate length of event parameter block, setting initial length to include version
223 and counts for each argument}
224
225 FEventBufferLen := 1;
226 for i := 0 to FEvents.Count - 1 do
227 FEventBufferLen := FEventBufferLen + length(FEvents[i]) + 1 + sizeof(Long);
228
229 with FFirebirdClientAPI do
230 begin
231 IBAlloc(FEventBuffer,0,FEventBufferLen);
232 if FEventBuffer = nil then Exit;
233 FillChar(FEventBuffer^,FEventBufferLen,0);
234 IBAlloc(FResultBuffer,0,FEventBufferLen);
235 if FResultBuffer = nil then
236 begin
237 FreeMem(FEventBuffer);
238 Exit;
239 end;
240 FillChar(FResultBuffer^,FEventBufferLen,0);
241
242 P := FEventBuffer;
243 P^ := EPB_version1;
244 Inc(P);
245 SetLength(FEventCounts,FEvents.Count);
246
247 for i := 0 to FEvents.Count - 1 do
248 begin
249 P^ := Length(FEvents[i]);
250 Inc(P);
251 Move(FEvents[i][1],P^,Length(FEvents[i]));
252 Inc(P,Length(FEvents[i])+sizeof(Long));
253 FEventCounts[i].EventName := FEvents[i];
254 end;
255 end;
256
257 { for i := 0 to FEventBufferLen - 1 do
258 write(Format('%x ', [FEventBuffer[i]]));
259 writeln;}
260 end;
261
262 procedure TFBEvents.CancelEvents(Force: boolean);
263 begin
264 FEventHandler := nil;
265 end;
266
267 procedure TFBEvents.EventSignaled;
268 var Handler: TEventHandler;
269 begin
270 Handler := nil;
271 FCriticalSection.Enter;
272 try
273 if not FInWaitState then Exit;
274 FInWaitState := false;
275 ProcessEventCounts;
276 if assigned(FEventHandler) then
277 begin
278 Handler := FEventHandler;
279 FEventHandler := nil;
280 end;
281 finally
282 FCriticalSection.Leave;
283 end;
284 if assigned(Handler) then
285 Handler(GetIEvents);
286 end;
287
288 (*
289 Original Firebird 'C' code for isc_event_counts
290
291 void API_ROUTINE isc_event_counts(ULONG* result_vector,
292 SSHORT buffer_length,
293 UCHAR* event_buffer,
294 const UCHAR* result_buffer)
295 {
296 /**************************************
297 *
298 * g d s _ $ e v e n t _ c o u n t s
299 *
300 **************************************
301 *
302 * Functional description
303 * Get the delta between two events in an event
304 * parameter block. Used to update gds_events
305 * for GPRE support of events.
306 *
307 **************************************/
308 ULONG* vec = result_vector;
309 const UCHAR* p = event_buffer;
310 const UCHAR* q = result_buffer;
311 USHORT length = buffer_length;
312 const UCHAR* const end = p + length;
313
314 // analyze the event blocks, getting the delta for each event
315
316 p++;
317 q++;
318 while (p < end)
319 {
320 // skip over the event name
321
322 const USHORT i = (USHORT)* p++;
323 p += i;
324 q += i + 1;
325
326 // get the change in count
327
328 const ULONG initial_count = gds__vax_integer(p, sizeof(SLONG));
329 p += sizeof(SLONG);
330 const ULONG new_count = gds__vax_integer(q, sizeof(SLONG));
331 q += sizeof(SLONG);
332 *vec++ = new_count - initial_count;
333 }
334
335 // copy over the result to the initial block to prepare
336 // for the next call to gds__event_wait
337
338 memcpy(event_buffer, result_buffer, length);
339 }
340 *)
341
342 {ProcessEventCounts effectively replaces isc_event_counts}
343
344 procedure TFBEvents.ProcessEventCounts;
345
346 var i: integer;
347 P, Q: PByte;
348 initial_count: Long;
349 new_count: Long;
350 len: byte;
351 begin
352 P := FEventBuffer;
353 Q := FResultBuffer;
354 Inc(P); {skip past version byte}
355 Inc(Q);
356 for i := 0 to Length(FEventCounts) - 1 do
357 with FFirebirdClientAPI do
358 begin
359 {skip over the event name}
360 len := P^;
361 P := P + len + 1;
362 Q := Q + len + 1; {event name length in P^}
363 initial_count := DecodeInteger(P,sizeof(Long));
364 Inc(P,sizeof(Long));
365 new_count := DecodeInteger(Q,sizeof(Long));
366 Inc(Q,sizeof(Long));
367 FEventCounts[i].Count := new_count - initial_count;
368 end;
369 Move(FResultBuffer^,FEventBuffer^,FEventBufferLen);
370 end;
371
372 constructor TFBEvents.Create(DBAttachment: IAttachment;
373 aMonitor: IActivityMonitor; Events: TStrings);
374 begin
375 inherited Create(aMonitor);
376 FAttachment := DBAttachment;
377 FFirebirdClientAPI := DBAttachment.getFirebirdAPI as TFBClientAPI;
378 if Events.Count > MaxEvents then
379 IBError(ibxeMaximumEvents, [nil]);
380
381 FCriticalSection := TCriticalSection.Create;
382 FEvents := TStringList.Create;
383 FEvents.Assign(Events);
384 CreateEventBlock;
385 end;
386
387 destructor TFBEvents.Destroy;
388 begin
389 if assigned(FCriticalSection) then FCriticalSection.Free;
390 if assigned(FEvents) then FEvents.Free;
391 with FFirebirdClientAPI do
392 begin
393 if FEventBuffer <> nil then
394 FreeMem( FEventBuffer);
395 if FResultBuffer <> nil then
396 FreeMem( FResultBuffer);
397 end;
398 inherited Destroy;
399 end;
400
401 procedure TFBEvents.GetEvents(EventNames: TStrings);
402 begin
403 EventNames.Assign(FEvents)
404 end;
405
406 procedure TFBEvents.SetEvents(EventNames: TStrings);
407 var i: integer;
408 begin
409 {$ifdef Unix}
410 if (EventNames.Count > 0) and not IsMultiThread then
411 IBError(ibxeMultiThreadRequired,['Firebird Events Handling']);
412 {$endif}
413 if EventNames.Text <> FEvents.Text then
414 begin
415 Cancel;
416 for i := 0 to EventNames.Count - 1 do
417 FEvents[i] := Trim(EventNames[i]);
418 CreateEventBlock;
419 end;
420 end;
421
422 procedure TFBEvents.SetEvents(Event: AnsiString);
423 var S: TStringList;
424 begin
425 S := TStringList.Create;
426 try
427 S.Add(Event);
428 SetEvents(S);
429 finally
430 S.Free;
431 end;
432 end;
433
434 procedure TFBEvents.Cancel;
435 begin
436 if assigned(FEventHandler) then
437 CancelEvents;
438 end;
439
440 function TFBEvents.ExtractEventCounts: TEventCounts;
441 begin
442 Result := FEventCounts;
443 end;
444
445 function TFBEvents.GetAttachment: IAttachment;
446 begin
447 Result := FAttachment;
448 end;
449
450 end.
451