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 382 by tony, Sat Jan 15 15:23:11 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
228		begin
229	<	if FEventBuffer <> nil then
131	<	isc_free( FEventBuffer);
229	>	FreeMem( FEventBuffer);
230		FEventBuffer := nil;
231	<	if FResultBuffer <> nil then
232	<	isc_free( FResultBuffer);
231	>	end;
232	>	if FResultBuffer <> nil then
233	>	begin
234	>	FreeMem( FResultBuffer);
235		FResultBuffer := nil;
236	+	end;
237
238	<	setlength(EventNames,MaxEvents);
239	<	try
240	<	for i := 0 to FEvents.Count-1 do
241	<	begin
242	<	EventName := FEvents[i];
243	<	EventNames[i] := PAnsiChar(EventName);
244	<	end;
238	>	FEventBufferLen := 1;
239	>	for i := 0 to FEvents.Count - 1 do
240	>	begin
241	>	s := FEvents[i];
242	>	FEventBufferLen := FEventBufferLen + length(s) + 1 + sizeof(Long);
243	>	end;
244	>
245	>	with FFirebirdClientAPI do
246	>	begin
247	>	IBAlloc(FEventBuffer,0,FEventBufferLen);
248	>	if FEventBuffer = nil then Exit;
249	>	FillChar(FEventBuffer^,FEventBufferLen,0);
250	>	IBAlloc(FResultBuffer,0,FEventBufferLen);
251	>	if FResultBuffer = nil then
252	>	begin
253	>	FreeMem(FEventBuffer);
254	>	FEventBuffer := nil;
255	>	Exit;
256	>	end;
257	>	FillChar(FResultBuffer^,FEventBufferLen,0);
258
259	<	FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
260	<	FEvents.Count,
261	<	EventNames[0],EventNames[1],EventNames[2],
262	<	EventNames[3],EventNames[4],EventNames[5],
263	<	EventNames[6],EventNames[7],EventNames[8],
264	<	EventNames[9],EventNames[10],EventNames[11],
265	<	EventNames[12],EventNames[13],EventNames[14]
266	<	);
267	<	finally
268	<	SetLength(EventNames,0)
259	>	P := FEventBuffer;
260	>	P^ := EPB_version1;
261	>	Inc(P);
262	>	SetLength(FEventCounts,FEvents.Count);
263	>
264	>	for i := 0 to FEvents.Count - 1 do
265	>	begin
266	>	s := FEvents[i];
267	>	P^ := Length(s);
268	>	Inc(P);
269	>	Move(s[1],P^,Length(s));
270	>	Inc(P,Length(s)+sizeof(Long));
271	>	FEventCounts[i].EventName := s;
272		end;
273		end;
274	+
275	+	{  for i := 0 to FEventBufferLen - 1 do
276	+	write(Format('%x ', [FEventBuffer[i]]));
277	+	writeln; }
278		end;
279
280		procedure TFBEvents.CancelEvents(Force: boolean);
#	Line 168 | Line 289 | begin
289		FCriticalSection.Enter;
290		try
291		if not FInWaitState then Exit;
292	<	FInWaitState := false;
172	<	ProcessEventCounts;
173	<	if assigned(FEventHandler)  then
292	>	if ProcessEventCounts and assigned(FEventHandler)  then
293		begin
294		Handler := FEventHandler;
295		FEventHandler := nil;
296	+	FInWaitState := false;
297		end;
298		finally
299		FCriticalSection.Leave;
#	Line 182 | Line 302 | begin
302		Handler(GetIEvents);
303		end;
304
305	<	procedure TFBEvents.ProcessEventCounts;
306	<	var P: PISC_LONG;
307	<	EventCountList: array[0..19] of ISC_LONG;
308	<	i: integer;
309	<	j: integer;
310	<	begin
311	<	SetLength(FEventCounts,0);
312	<	if FResultBuffer = nil then Exit;
313	<
314	<	FillChar(EventCountList,sizeof(EventCountList),0);
315	<
316	<	with FirebirdClientAPI do
317	<	isc_event_counts( @EventCountList, FEventBufferLen, FEventBuffer, FResultBuffer);
318	<	j := 0;
319	<	P := @EventCountList;
320	<	for i := 0 to FEvents.Count - 1 do
305	>	(*
306	>	Original Firebird 'C' code for isc_event_counts
307	>
308	>	void API_ROUTINE isc_event_counts(ULONG* result_vector,
309	>	SSHORT buffer_length,
310	>	UCHAR* event_buffer,
311	>	const UCHAR* result_buffer)
312	>	{
313	>	/**************************************
314	>	*
315	>	*      g d s _ $ e v e n t _ c o u n t s
316	>	*
317	>	**************************************
318	>	*
319	>	* Functional description
320	>	*      Get the delta between two events in an event
321	>	*      parameter block.  Used to update gds_events
322	>	*      for GPRE support of events.
323	>	*
324	>	**************************************/
325	>	ULONG* vec = result_vector;
326	>	const UCHAR* p = event_buffer;
327	>	const UCHAR* q = result_buffer;
328	>	USHORT length = buffer_length;
329	>	const UCHAR* const end = p + length;
330	>
331	>	// analyze the event blocks, getting the delta for each event
332	>
333	>	p++;
334	>	q++;
335	>	while (p < end)
336	>	{
337	>	// skip over the event name
338	>
339	>	const USHORT i = (USHORT)* p++;
340	>	p += i;
341	>	q += i + 1;
342	>
343	>	// get the change in count
344	>
345	>	const ULONG initial_count = gds__vax_integer(p, sizeof(SLONG));
346	>	p += sizeof(SLONG);
347	>	const ULONG new_count = gds__vax_integer(q, sizeof(SLONG));
348	>	q += sizeof(SLONG);
349	>	*vec++ = new_count - initial_count;
350	>	}
351	>
352	>	// copy over the result to the initial block to prepare
353	>	// for the next call to gds__event_wait
354	>
355	>	memcpy(event_buffer, result_buffer, length);
356	>	}
357	>	*)
358	>
359	>	{ProcessEventCounts effectively replaces isc_event_counts}
360	>
361	>	function TFBEvents.ProcessEventCounts: boolean;
362	>
363	>	var i: integer;
364	>	P, Q: PByte;
365	>	initial_count: Long;
366	>	new_count: Long;
367	>	len: byte;
368	>	begin
369	>	Result := false;
370	>	P := FEventBuffer;
371	>	Q := FResultBuffer;
372	>	Inc(P); {skip past version byte}
373	>	Inc(Q);
374	>	for i := 0 to Length(FEventCounts) - 1 do
375	>	with FFirebirdClientAPI do
376		begin
377	<	if EventCountList[i] <> 0 then
378	<	begin
379	<	Inc(j);
380	<	SetLength(FEventCounts,j);
381	<	FEventCounts[j-1].EventName := FEvents[i];
382	<	FEventCounts[j-1].Count := P^;
383	<	Inc(P);
384	<	//      writeln('Event: ',FEventCounts[j-1].EventName,' Count = ',FEventCounts[j-1].Count);
385	<	end;
377	>	{skip over the event name}
378	>	len := P^;
379	>	P := P + len + 1;
380	>	Q := Q + len + 1; {event name length in P^}
381	>	initial_count := DecodeInteger(P,sizeof(Long));
382	>	Inc(P,sizeof(Long));
383	>	new_count := DecodeInteger(Q,sizeof(Long));
384	>	Inc(Q,sizeof(Long));
385	>	FEventCounts[i].Count := new_count - initial_count;
386	>	if FEventCounts[i].Count > 0 then
387	>	Result := true;
388	>	//  writeln('Event Count[',i,'] = ',FEventCounts[i].Count);
389		end;
390	+	Move(FResultBuffer^,FEventBuffer^,FEventBufferLen);
391		end;
392
393		constructor TFBEvents.Create(DBAttachment: IAttachment;
#	Line 216 | Line 395 | constructor TFBEvents.Create(DBAttachmen
395		begin
396		inherited Create(aMonitor);
397		FAttachment := DBAttachment;
398	+	FFirebirdClientAPI := DBAttachment.getFirebirdAPI as TFBClientAPI;
399		if Events.Count > MaxEvents then
400		IBError(ibxeMaximumEvents, [nil]);
401
#	Line 229 | Line 409 | destructor TFBEvents.Destroy;
409		begin
410		if assigned(FCriticalSection) then FCriticalSection.Free;
411		if assigned(FEvents) then FEvents.Free;
412	<	with FirebirdClientAPI do
412	>	with FFirebirdClientAPI do
413		begin
414		if FEventBuffer <> nil then
415	<	isc_free( FEventBuffer);
415	>	FreeMem( FEventBuffer);
416		if FResultBuffer <> nil then
417	<	isc_free( FResultBuffer);
417	>	FreeMem( FResultBuffer);
418		end;
419		inherited Destroy;
420		end;
#	Line 245 | Line 425 | begin
425		end;
426
427		procedure TFBEvents.SetEvents(EventNames: TStrings);
428	+	var i: integer;
429		begin
430	+	{$ifdef Unix}
431	+	if (EventNames.Count > 0) and not IsMultiThread then
432	+	IBError(ibxeMultiThreadRequired,['Firebird Events Handling']);
433	+	{$endif}
434		if EventNames.Text <> FEvents.Text then
435		begin
436		Cancel;
437	<	FEvents.Assign(EventNames);
437	>	for i := 0 to EventNames.Count - 1 do
438	>	FEvents[i] := Trim(EventNames[i]);
439		CreateEventBlock;
440		end;
441		end;
442
443	<	procedure TFBEvents.SetEvents(Event: AnsiString);
443	>	procedure TFBEvents.SetEvents(Event: string);
444		var S: TStringList;
445		begin
446		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 382 by tony, Sat Jan 15 15:23:11 2022 UTC

#	Line 0 | Line 1
1	+	native

Diff Legend

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