ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/FBEvents.pas
(Generate patch)

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