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 56 by tony, Mon Mar 6 10:20:02 2017 UTC vs.
ibx/branches/udr/client/FBEvents.pas (file contents), Revision 381 by tony, Sat Jan 15 00:06:22 2022 UTC

#	Line 60 | Line 60
60		{                                                                        }
61		{************************************************************************}
62		unit FBEvents;
63	<	{$IFDEF MSWINDOWS}
64	<	{$DEFINE WINDOWS}
63	>	{$IFDEF MSWINDOWS}
64	>	{$DEFINE WINDOWS}
65		{$ENDIF}
66
67		{$IFDEF FPC}
#	Line 78 | 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: PByte;
102		FEventBufferLen: integer;
#	Line 94 | Line 108 | type
108		procedure CancelEvents(Force: boolean = false); virtual;
109		procedure EventSignaled;
110		function GetIEvents: IEvents; virtual; abstract;
111	<	procedure ProcessEventCounts;
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;
#	Line 102 | Line 118 | type
118		{IEvents}
119		procedure GetEvents(EventNames: TStrings);
120		procedure SetEvents(EventNames: TStrings); overload;
121	<	procedure SetEvents(Event: AnsiString); 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
#	Line 119 | Line 136 | const
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
221	<	i: integer;
222	<	EventNames: array of PAnsiChar;
126	<	EventName: AnsiString;
220	>	var i: integer;
221	>	P: PByte;
222	>	var s: Ansistring;
223		begin
224	<	with FirebirdClientAPI do
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	<	if FEventBuffer <> nil then
234	<	isc_free( FEventBuffer);
235	<	FEventBuffer := nil;
133	<	if FResultBuffer <> nil then
134	<	isc_free( FResultBuffer);
135	<	FResultBuffer := nil;
233	>	s := FEvents[i];
234	>	FEventBufferLen := FEventBufferLen + length(s) + 1 + sizeof(Long);
235	>	end;
236
237	<	setlength(EventNames,MaxEvents);
238	<	try
239	<	for i := 0 to FEvents.Count-1 do
240	<	begin
241	<	EventName := FEvents[i];
242	<	EventNames[i] := PAnsiChar(EventName);
243	<	end;
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	<	FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
251	<	FEvents.Count,
252	<	EventNames[0],EventNames[1],EventNames[2],
253	<	EventNames[3],EventNames[4],EventNames[5],
254	<	EventNames[6],EventNames[7],EventNames[8],
255	<	EventNames[9],EventNames[10],EventNames[11],
256	<	EventNames[12],EventNames[13],EventNames[14]
257	<	);
258	<	finally
259	<	SetLength(EventNames,0)
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);
#	Line 168 | Line 280 | begin
280		FCriticalSection.Enter;
281		try
282		if not FInWaitState then Exit;
283	<	FInWaitState := false;
172	<	ProcessEventCounts;
173	<	if assigned(FEventHandler)  then
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;
#	Line 182 | Line 293 | begin
293		Handler(GetIEvents);
294		end;
295
296	<	procedure TFBEvents.ProcessEventCounts;
297	<	var P: PISC_LONG;
298	<	EventCountList: array[0..19] of ISC_LONG;
299	<	i: integer;
300	<	j: integer;
301	<	begin
302	<	SetLength(FEventCounts,0);
303	<	if FResultBuffer = nil then Exit;
304	<
305	<	FillChar(EventCountList,sizeof(EventCountList),0);
306	<
307	<	with FirebirdClientAPI do
308	<	isc_event_counts( @EventCountList, FEventBufferLen, FEventBuffer, FResultBuffer);
309	<	j := 0;
310	<	P := @EventCountList;
311	<	for i := 0 to FEvents.Count - 1 do
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	<	if EventCountList[i] <> 0 then
369	<	begin
370	<	Inc(j);
371	<	SetLength(FEventCounts,j);
372	<	FEventCounts[j-1].EventName := FEvents[i];
373	<	FEventCounts[j-1].Count := P^;
374	<	Inc(P);
375	<	//      writeln('Event: ',FEventCounts[j-1].EventName,' Count = ',FEventCounts[j-1].Count);
376	<	end;
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;
#	Line 216 | Line 386 | constructor TFBEvents.Create(DBAttachmen
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
#	Line 229 | Line 400 | destructor TFBEvents.Destroy;
400		begin
401		if assigned(FCriticalSection) then FCriticalSection.Free;
402		if assigned(FEvents) then FEvents.Free;
403	<	with FirebirdClientAPI do
403	>	with FFirebirdClientAPI do
404		begin
405		if FEventBuffer <> nil then
406	<	isc_free( FEventBuffer);
406	>	FreeMem( FEventBuffer);
407		if FResultBuffer <> nil then
408	<	isc_free( FResultBuffer);
408	>	FreeMem( FResultBuffer);
409		end;
410		inherited Destroy;
411		end;
#	Line 245 | Line 416 | begin
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	<	FEvents.Assign(EventNames);
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: AnsiString);
434	>	procedure TFBEvents.SetEvents(Event: string);
435		var S: TStringList;
436		begin
437		S := TStringList.Create;

Comparing:
ibx/trunk/fbintf/client/FBEvents.pas (property svn:eol-style), Revision 56 by tony, Mon Mar 6 10:20:02 2017 UTC vs.
ibx/branches/udr/client/FBEvents.pas (property svn:eol-style), Revision 381 by tony, Sat Jan 15 00:06:22 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

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