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

Properties

Name Value
svn:eol-style native