ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/branches/udr/client/FBEvents.pas

Comparing:
ibx/trunk/fbintf/client/FBEvents.pas (file contents), Revision 45 by tony, Tue Dec 6 10:33:46 2016 UTC vs.
ibx/branches/udr/client/FBEvents.pas (file contents), Revision 371 by tony, Wed Jan 5 15:21:22 2022 UTC

#	Line 60 | Line 60
60		{                                                                        }
61		{************************************************************************}
62		unit FBEvents;
63	+	{$IFDEF MSWINDOWS}
64	+	{$DEFINE WINDOWS}
65	+	{$ENDIF}
66
67		{$IFDEF FPC}
68	<	{$mode objfpc}{$H+}
68	>	{$mode delphi}
69		{$interfaces COM}
70		{$ENDIF}
71
#	Line 75 | Line 78 | 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: PChar;
101	>	FEventBuffer: PByte;
102		FEventBufferLen: integer;
103	<	FResultBuffer: PChar;
103	>	FResultBuffer: PByte;
104		FEventHandler: TEventHandler;
105		FCriticalSection: TCriticalSection;
106		FInWaitState: boolean;
#	Line 90 | Line 108 | type
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;
#	Line 97 | Line 118 | type
118		{IEvents}
119		procedure GetEvents(EventNames: TStrings);
120		procedure SetEvents(EventNames: TStrings); overload;
121	<	procedure SetEvents(Event: string); 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
#	Line 113 | Line 135 | const
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
220	<	i: integer;
119	<	EventNames: array of PChar;
219	>	var i: integer;
220	>	P: PByte;
221		begin
222	<	with FirebirdClientAPI do
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	<	if FEventBuffer <> nil then
232	<	isc_free( FEventBuffer);
233	<	FEventBuffer := nil;
234	<	if FResultBuffer <> nil then
235	<	isc_free( FResultBuffer);
236	<	FResultBuffer := nil;
231	>	IBAlloc(FEventBuffer,0,FEventBufferLen);
232	>	if FEventBuffer = nil then Exit;
233	>	{$if declared(FillByte)}
234	>	FillByte(FEventBuffer^,FEventBufferLen,0);
235	>	{$else}
236	>	FillChar(FEventBuffer^,FEventBufferLen,0);
237	>	{$ifend}
238	>	IBAlloc(FResultBuffer,0,FEventBufferLen);
239	>	if FResultBuffer = nil then
240	>	begin
241	>	FreeMem(FEventBuffer);
242	>	Exit;
243	>	end;
244	>
245	>	P := FEventBuffer;
246	>	P^ := EPB_version1;
247	>	Inc(P);
248	>	SetLength(FEventCounts,FEvents.Count);
249
250	<	setlength(EventNames,MaxEvents);
251	<	try
252	<	for i := 0 to FEvents.Count-1 do
253	<	EventNames[i] := PChar(FEvents[i]);
254	<
255	<	FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
256	<	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)
250	>	for i := 0 to FEvents.Count - 1 do
251	>	begin
252	>	P^ := Length(FEvents[i]);
253	>	Inc(P);
254	>	Move(FEvents[i][1],P^,Length(FEvents[i]));
255	>	Inc(P,Length(FEvents[i])+sizeof(Long));
256	>	FEventCounts[i].EventName := FEvents[i];
257		end;
258		end;
259	+
260	+	{  for i := 0 to FEventBufferLen - 1 do
261	+	write(Format('%x ', [FEventBuffer[i]]));
262	+	writeln;}
263		end;
264
265		procedure TFBEvents.CancelEvents(Force: boolean);
#	Line 154 | Line 270 | end;
270		procedure TFBEvents.EventSignaled;
271		var Handler: TEventHandler;
272		begin
273	+	Handler := nil;
274		FCriticalSection.Enter;
275		try
276		if not FInWaitState then Exit;
277		FInWaitState := false;
278	+	ProcessEventCounts;
279		if assigned(FEventHandler)  then
280		begin
281		Handler := FEventHandler;
282		FEventHandler := nil;
283		end;
284		finally
285	<	FCriticalSection.Leave
285	>	FCriticalSection.Leave;
286	>	end;
287	>	if assigned(Handler) then
288	>	Handler(GetIEvents);
289	>	end;
290	>
291	>	(*
292	>	Original Firebird 'C' code for isc_event_counts
293	>
294	>	void API_ROUTINE isc_event_counts(ULONG* result_vector,
295	>	SSHORT buffer_length,
296	>	UCHAR* event_buffer,
297	>	const UCHAR* result_buffer)
298	>	{
299	>	/**************************************
300	>	*
301	>	*      g d s _ $ e v e n t _ c o u n t s
302	>	*
303	>	**************************************
304	>	*
305	>	* Functional description
306	>	*      Get the delta between two events in an event
307	>	*      parameter block.  Used to update gds_events
308	>	*      for GPRE support of events.
309	>	*
310	>	**************************************/
311	>	ULONG* vec = result_vector;
312	>	const UCHAR* p = event_buffer;
313	>	const UCHAR* q = result_buffer;
314	>	USHORT length = buffer_length;
315	>	const UCHAR* const end = p + length;
316	>
317	>	// analyze the event blocks, getting the delta for each event
318	>
319	>	p++;
320	>	q++;
321	>	while (p < end)
322	>	{
323	>	// skip over the event name
324	>
325	>	const USHORT i = (USHORT)* p++;
326	>	p += i;
327	>	q += i + 1;
328	>
329	>	// get the change in count
330	>
331	>	const ULONG initial_count = gds__vax_integer(p, sizeof(SLONG));
332	>	p += sizeof(SLONG);
333	>	const ULONG new_count = gds__vax_integer(q, sizeof(SLONG));
334	>	q += sizeof(SLONG);
335	>	*vec++ = new_count - initial_count;
336	>	}
337	>
338	>	// copy over the result to the initial block to prepare
339	>	// for the next call to gds__event_wait
340	>
341	>	memcpy(event_buffer, result_buffer, length);
342	>	}
343	>	*)
344	>
345	>	{ProcessEventCounts effectively replaces isc_event_counts}
346	>
347	>	procedure TFBEvents.ProcessEventCounts;
348	>
349	>	var i: integer;
350	>	P, Q: PByte;
351	>	initial_count: Long;
352	>	new_count: Long;
353	>	len: byte;
354	>	begin
355	>	P := FEventBuffer;
356	>	Q := FResultBuffer;
357	>	Inc(P); {skip past version byte}
358	>	Inc(Q);
359	>	for i := 0 to Length(FEventCounts) - 1 do
360	>	with FFirebirdClientAPI do
361	>	begin
362	>	{skip over the event name}
363	>	len := P^;
364	>	P := P + len + 1;
365	>	Q := Q + len + 1; {event name length in P^}
366	>	initial_count := DecodeInteger(P,sizeof(Long));
367	>	Inc(P,sizeof(Long));
368	>	new_count := DecodeInteger(Q,sizeof(Long));
369	>	Inc(Q,sizeof(Long));
370	>	FEventCounts[i].Count := new_count - initial_count;
371		end;
372	<	Handler(GetIEvents);
372	>	Move(FResultBuffer^,FEventBuffer^,FEventBufferLen);
373		end;
374
375		constructor TFBEvents.Create(DBAttachment: IAttachment;
#	Line 174 | Line 377 | constructor TFBEvents.Create(DBAttachmen
377		begin
378		inherited Create(aMonitor);
379		FAttachment := DBAttachment;
380	+	FFirebirdClientAPI := DBAttachment.getFirebirdAPI as TFBClientAPI;
381		if Events.Count > MaxEvents then
382		IBError(ibxeMaximumEvents, [nil]);
383
#	Line 187 | Line 391 | destructor TFBEvents.Destroy;
391		begin
392		if assigned(FCriticalSection) then FCriticalSection.Free;
393		if assigned(FEvents) then FEvents.Free;
394	<	with FirebirdClientAPI do
394	>	with FFirebirdClientAPI do
395		begin
396		if FEventBuffer <> nil then
397	<	isc_free( FEventBuffer);
397	>	FreeMem( FEventBuffer);
398		if FResultBuffer <> nil then
399	<	isc_free( FResultBuffer);
399	>	FreeMem( FResultBuffer);
400		end;
401		inherited Destroy;
402		end;
#	Line 203 | Line 407 | begin
407		end;
408
409		procedure TFBEvents.SetEvents(EventNames: TStrings);
410	+	var i: integer;
411		begin
412	+	{$ifdef Unix}
413	+	if (EventNames.Count > 0) and not IsMultiThread then
414	+	IBError(ibxeMultiThreadRequired,['Firebird Events Handling']);
415	+	{$endif}
416		if EventNames.Text <> FEvents.Text then
417		begin
418		Cancel;
419	<	FEvents.Assign(EventNames);
419	>	for i := 0 to EventNames.Count - 1 do
420	>	FEvents[i] := Trim(EventNames[i]);
421		CreateEventBlock;
422		end;
423		end;
424
425	<	procedure TFBEvents.SetEvents(Event: string);
425	>	procedure TFBEvents.SetEvents(Event: AnsiString);
426		var S: TStringList;
427		begin
428		S := TStringList.Create;
#	Line 231 | Line 441 | begin
441		end;
442
443		function TFBEvents.ExtractEventCounts: TEventCounts;
234	–	var EventCountList, P: PISC_LONG;
235	–	i: integer;
236	–	j: integer;
444		begin
445	<	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;
445	>	Result := FEventCounts;
446		end;
447
448		function TFBEvents.GetAttachment: IAttachment;

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines