trunk/runtime/IBEvents.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{************************************************************************}

unit IBEvents;

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DB, IBHeader, IBExternals, IB, IBDatabase;

const
  MaxEvents = 15;
  EventLength = 64;

type

  TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
                           var CancelAlerts: Boolean) of object;

  TEventBuffer = array[ 0..MaxEvents-1, 0..EventLength-1] of char;

  TIBEvents = class(TComponent)
  private
    FIBLoaded: Boolean;
    FEvents: TStrings;
    FOnEventAlert: TEventAlert;
    FQueued: Boolean;
    FRegistered: Boolean;
    Buffer: TEventBuffer;
    Changing: Boolean;
    CS: TRTLCriticalSection;
    EventBuffer: PChar;
    EventBufferLen: integer;
    EventID: ISC_LONG;
    ProcessingEvents: Boolean;
    RegisteredState: Boolean;
    ResultBuffer: PChar;
    FDatabase: TIBDatabase;
    procedure SetDatabase( value: TIBDatabase);
    procedure ValidateDatabase( Database: TIBDatabase);
    procedure DoQueueEvents;
    procedure EventChange( sender: TObject);
    procedure UpdateResultBuffer( length: short; updated: PChar);
  protected
    procedure HandleEvent;
    procedure Loaded; override;
    procedure Notification( AComponent: TComponent; Operation: TOperation); override;
    procedure SetEvents( value: TStrings);
    procedure SetRegistered( value: boolean);
    function  GetNativeHandle: TISC_DB_HANDLE;

  public
    constructor Create( AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CancelEvents;
    procedure QueueEvents;
    procedure RegisterEvents;
    procedure UnRegisterEvents;
    property  Queued: Boolean read FQueued;
  published
    property  Database: TIBDatabase read FDatabase write SetDatabase;
    property Events: TStrings read FEvents write SetEvents;
    property Registered: Boolean read FRegistered write SetRegistered;
    property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
  end;

implementation

uses
  IBIntf;

function TIBEvents.GetNativeHandle: TISC_DB_HANDLE;
begin
  if assigned( FDatabase) and FDatabase.Connected then
    Result := FDatabase.Handle
  else result := nil;
end;

procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
begin
  if not assigned( Database) then
    IBError(ibxeDatabaseNameMissing, [nil]);
  if not Database.Connected then
    IBError(ibxeDatabaseClosed, [nil]);
end;

{ TIBEvents }

procedure HandleEvent( param: integer); stdcall;
begin
  { don't let exceptions propogate out of thread }
  try
    TIBEvents( param).HandleEvent;
  except
    Application.HandleException( nil);
  end;
end;

procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
var
  ThreadID: DWORD;
begin
  { Handle events asynchronously in second thread }
  EnterCriticalSection( TIBEvents( ptr).CS);
  TIBEvents( ptr).UpdateResultBuffer( length, updated);
  if TIBEvents( ptr).Queued then
    CloseHandle( CreateThread( nil, 8192, @HandleEvent, ptr, 0, ThreadID));
  LeaveCriticalSection( TIBEvents( ptr).CS);
end;

constructor TIBEvents.Create( AOwner: TComponent);
begin
  inherited Create( AOwner);
  FIBLoaded := False;
  CheckIBLoaded;
  FIBLoaded := True;
  InitializeCriticalSection( CS);
  FEvents := TStringList.Create;
  with TStringList( FEvents) do
  begin
    OnChange := EventChange;
    Duplicates := dupIgnore;
  end;
end;

destructor TIBEvents.Destroy;
begin
  if FIBLoaded then
  begin
    UnregisterEvents;
    SetDatabase( nil);
    TStringList(FEvents).OnChange := nil;
    FEvents.Free;
    DeleteCriticalSection( CS);
  end;
  inherited Destroy;
end;

procedure TIBEvents.CancelEvents;
begin
  if ProcessingEvents then
    IBError(ibxeInvalidCancellation, [nil]);  
  if FQueued then
  begin
    try
      { wait for event handler to finish before cancelling events }
      EnterCriticalSection( CS);
      ValidateDatabase( Database);
      FQueued := false;
      Changing := true;
      if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
        IBDatabaseError;
    finally
      LeaveCriticalSection( CS);
    end;
  end;
end;

procedure TIBEvents.DoQueueEvents;
var
  callback: pointer;
begin
  ValidateDatabase( DataBase);
  callback := @IBEventCallback;
  if (isc_que_events( StatusVector, @FDatabase.Handle, @EventID, EventBufferLen,
                     EventBuffer, TISC_CALLBACK(callback), PVoid(Self)) > 0) then
    IBDatabaseError;
  FQueued := true;
end;

procedure TIBEvents.EventChange( sender: TObject);
begin
  { check for blank event }
  if TStringList(Events).IndexOf( '') <> -1 then
    IBError(ibxeInvalidEvent, [nil]);
  { check for too many events }
  if Events.Count > MaxEvents then
  begin
    TStringList(Events).OnChange := nil;
    Events.Delete( MaxEvents);
    TStringList(Events).OnChange := EventChange;
    IBError(ibxeMaximumEvents, [nil]);
  end;
  if Registered then RegisterEvents;
end;

procedure TIBEvents.HandleEvent;
var
  Status: PStatusVector;
  CancelAlerts: Boolean;
  i: integer;
begin
  try
    { prevent modification of vital data structures while handling events }
    EnterCriticalSection( CS);
    ProcessingEvents := true;
    isc_event_counts( StatusVector, EventBufferLen, EventBuffer, ResultBuffer);
    CancelAlerts := false;
    if assigned(FOnEventAlert) and not Changing then
    begin
      for i := 0 to Events.Count-1 do
      begin
        try
        Status := StatusVectorArray;
        if (Status[i] <> 0) and not CancelAlerts then
            FOnEventAlert( self, Events[Events.Count-i-1], Status[i], CancelAlerts);
        except
          Application.HandleException( nil);
        end;
      end;
    end;
    Changing := false;
    if not CancelAlerts and FQueued then DoQueueEvents;
  finally
    ProcessingEvents := false;
    LeaveCriticalSection( CS);
  end;
end;

procedure TIBEvents.Loaded;
begin
  inherited Loaded;
  try
    if RegisteredState then RegisterEvents;
  except
    if csDesigning in ComponentState then
      Application.HandleException( self)
    else raise;
  end;
end;

procedure TIBEvents.Notification( AComponent: TComponent;
                                        Operation: TOperation);
begin
  inherited Notification( AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FDatabase) then
  begin
    UnregisterEvents;
    FDatabase := nil;
  end;
end;

procedure TIBEvents.QueueEvents;
begin
  if not FRegistered then
    IBError(ibxeNoEventsRegistered, [nil]);
  if ProcessingEvents then
    IBError(ibxeInvalidQueueing, [nil]);
  if not FQueued then
  begin
    try
      { wait until current event handler is finished before queuing events }
      EnterCriticalSection( CS);
      DoQueueEvents;
      Changing := true;
    finally
      LeaveCriticalSection( CS);
    end;
  end;
end;

procedure TIBEvents.RegisterEvents;
var
  i: integer;
  bufptr: pointer;
  eventbufptr: pointer;
  resultbufptr: pointer;
  buflen: integer;
begin
  ValidateDatabase( Database);
  if csDesigning in ComponentState then FRegistered := true
  else begin
    UnregisterEvents;
    if Events.Count = 0 then exit;
    for i := 0 to Events.Count-1 do
      StrPCopy( @Buffer[i][0], Events[i]);
    i := Events.Count;
    bufptr := @buffer[0];
    eventbufptr :=  @EventBuffer;
    resultBufPtr := @ResultBuffer;
    asm
      mov ecx, dword ptr [i]
      mov eax, dword ptr [bufptr]
      @@1:
      push eax
      add  eax, EventLength
      loop @@1
      push dword ptr [i]
      push dword ptr [resultBufPtr]
      push dword ptr [eventBufPtr]
      call [isc_event_block]
      mov  dword ptr [bufLen], eax
      mov eax, dword ptr [i]
      shl eax, 2
      add eax, 12
      add esp, eax
    end;
    EventBufferlen := Buflen;
    FRegistered := true;
    QueueEvents;
  end;
end;

procedure TIBEvents.SetEvents( value: TStrings);
begin
  FEvents.Assign( value);
end;

procedure TIBEvents.SetDatabase( value: TIBDatabase);
begin
  if value <> FDatabase then
  begin
    UnregisterEvents;
    if assigned( value) and value.Connected then ValidateDatabase( value);
    FDatabase := value;
  end;
end;

procedure TIBEvents.SetRegistered( value: Boolean);
begin
  if (csReading in ComponentState) then
    RegisteredState := value
  else if FRegistered <> value then
    if value then RegisterEvents else UnregisterEvents;
end;

procedure TIBEvents.UnregisterEvents;
begin
  if ProcessingEvents then
    IBError(ibxeInvalidRegistration, [nil]);
  if csDesigning in ComponentState then
    FRegistered := false
  else if not (csLoading in ComponentState) then
  begin
    CancelEvents;
    if FRegistered then
    begin
      isc_free( EventBuffer);
      EventBuffer := nil;
      isc_free( ResultBuffer);
      ResultBuffer := nil;
    end;
    FRegistered := false;
  end;
end;

procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
var
  i: integer;
begin
  for i := 0 to length-1 do
    ResultBuffer[i] := updated[i];
end;

end.
Revision:	1
Committed:	Mon Jul 31 16:43:00 2000 UTC (24 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	10947 byte(s)
Log Message:	Borland IBX Open Source Release
#	User	Rev	Content
1	tony	1	{************************************************************************}
2			{ }
3			{ Borland Delphi Visual Component Library }
4			{ InterBase Express core components }
5			{ }
6			{ Copyright (c) 1998-2000 Inprise Corporation }
7			{ }
8			{ InterBase Express is based in part on the product }
9			{ Free IB Components, written by Gregory H. Deatz for }
10			{ Hoagland, Longo, Moran, Dunst & Doukas Company. }
11			{ Free IB Components is used under license. }
12			{ }
13			{ The contents of this file are subject to the InterBase }
14			{ Public License Version 1.0 (the "License"); you may not }
15			{ use this file except in compliance with the License. You }
16			{ may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17			{ Software distributed under the License is distributed on }
18			{ an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either }
19			{ express or implied. See the License for the specific language }
20			{ governing rights and limitations under the License. }
21			{ The Original Code was created by InterBase Software Corporation }
22			{ and its successors. }
23			{ Portions created by Inprise Corporation are Copyright (C) Inprise }
24			{ Corporation. All Rights Reserved. }
25			{ Contributor(s): Jeff Overcash }
26			{ }
27			{************************************************************************}
28
29			unit IBEvents;
30
31			interface
32
33			uses
34			SysUtils, Windows, Messages, Classes, Graphics, Controls,
35			Forms, Dialogs, DB, IBHeader, IBExternals, IB, IBDatabase;
36
37			const
38			MaxEvents = 15;
39			EventLength = 64;
40
41			type
42
43			TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
44			var CancelAlerts: Boolean) of object;
45
46			TEventBuffer = array[ 0..MaxEvents-1, 0..EventLength-1] of char;
47
48			TIBEvents = class(TComponent)
49			private
50			FIBLoaded: Boolean;
51			FEvents: TStrings;
52			FOnEventAlert: TEventAlert;
53			FQueued: Boolean;
54			FRegistered: Boolean;
55			Buffer: TEventBuffer;
56			Changing: Boolean;
57			CS: TRTLCriticalSection;
58			EventBuffer: PChar;
59			EventBufferLen: integer;
60			EventID: ISC_LONG;
61			ProcessingEvents: Boolean;
62			RegisteredState: Boolean;
63			ResultBuffer: PChar;
64			FDatabase: TIBDatabase;
65			procedure SetDatabase( value: TIBDatabase);
66			procedure ValidateDatabase( Database: TIBDatabase);
67			procedure DoQueueEvents;
68			procedure EventChange( sender: TObject);
69			procedure UpdateResultBuffer( length: short; updated: PChar);
70			protected
71			procedure HandleEvent;
72			procedure Loaded; override;
73			procedure Notification( AComponent: TComponent; Operation: TOperation); override;
74			procedure SetEvents( value: TStrings);
75			procedure SetRegistered( value: boolean);
76			function GetNativeHandle: TISC_DB_HANDLE;
77
78			public
79			constructor Create( AOwner: TComponent); override;
80			destructor Destroy; override;
81			procedure CancelEvents;
82			procedure QueueEvents;
83			procedure RegisterEvents;
84			procedure UnRegisterEvents;
85			property Queued: Boolean read FQueued;
86			published
87			property Database: TIBDatabase read FDatabase write SetDatabase;
88			property Events: TStrings read FEvents write SetEvents;
89			property Registered: Boolean read FRegistered write SetRegistered;
90			property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
91			end;
92
93			implementation
94
95			uses
96			IBIntf;
97
98			function TIBEvents.GetNativeHandle: TISC_DB_HANDLE;
99			begin
100			if assigned( FDatabase) and FDatabase.Connected then
101			Result := FDatabase.Handle
102			else result := nil;
103			end;
104
105			procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
106			begin
107			if not assigned( Database) then
108			IBError(ibxeDatabaseNameMissing, [nil]);
109			if not Database.Connected then
110			IBError(ibxeDatabaseClosed, [nil]);
111			end;
112
113			{ TIBEvents }
114
115			procedure HandleEvent( param: integer); stdcall;
116			begin
117			{ don't let exceptions propogate out of thread }
118			try
119			TIBEvents( param).HandleEvent;
120			except
121			Application.HandleException( nil);
122			end;
123			end;
124
125			procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
126			var
127			ThreadID: DWORD;
128			begin
129			{ Handle events asynchronously in second thread }
130			EnterCriticalSection( TIBEvents( ptr).CS);
131			TIBEvents( ptr).UpdateResultBuffer( length, updated);
132			if TIBEvents( ptr).Queued then
133			CloseHandle( CreateThread( nil, 8192, @HandleEvent, ptr, 0, ThreadID));
134			LeaveCriticalSection( TIBEvents( ptr).CS);
135			end;
136
137			constructor TIBEvents.Create( AOwner: TComponent);
138			begin
139			inherited Create( AOwner);
140			FIBLoaded := False;
141			CheckIBLoaded;
142			FIBLoaded := True;
143			InitializeCriticalSection( CS);
144			FEvents := TStringList.Create;
145			with TStringList( FEvents) do
146			begin
147			OnChange := EventChange;
148			Duplicates := dupIgnore;
149			end;
150			end;
151
152			destructor TIBEvents.Destroy;
153			begin
154			if FIBLoaded then
155			begin
156			UnregisterEvents;
157			SetDatabase( nil);
158			TStringList(FEvents).OnChange := nil;
159			FEvents.Free;
160			DeleteCriticalSection( CS);
161			end;
162			inherited Destroy;
163			end;
164
165			procedure TIBEvents.CancelEvents;
166			begin
167			if ProcessingEvents then
168			IBError(ibxeInvalidCancellation, [nil]);
169			if FQueued then
170			begin
171			try
172			{ wait for event handler to finish before cancelling events }
173			EnterCriticalSection( CS);
174			ValidateDatabase( Database);
175			FQueued := false;
176			Changing := true;
177			if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
178			IBDatabaseError;
179			finally
180			LeaveCriticalSection( CS);
181			end;
182			end;
183			end;
184
185			procedure TIBEvents.DoQueueEvents;
186			var
187			callback: pointer;
188			begin
189			ValidateDatabase( DataBase);
190			callback := @IBEventCallback;
191			if (isc_que_events( StatusVector, @FDatabase.Handle, @EventID, EventBufferLen,
192			EventBuffer, TISC_CALLBACK(callback), PVoid(Self)) > 0) then
193			IBDatabaseError;
194			FQueued := true;
195			end;
196
197			procedure TIBEvents.EventChange( sender: TObject);
198			begin
199			{ check for blank event }
200			if TStringList(Events).IndexOf( '') <> -1 then
201			IBError(ibxeInvalidEvent, [nil]);
202			{ check for too many events }
203			if Events.Count > MaxEvents then
204			begin
205			TStringList(Events).OnChange := nil;
206			Events.Delete( MaxEvents);
207			TStringList(Events).OnChange := EventChange;
208			IBError(ibxeMaximumEvents, [nil]);
209			end;
210			if Registered then RegisterEvents;
211			end;
212
213			procedure TIBEvents.HandleEvent;
214			var
215			Status: PStatusVector;
216			CancelAlerts: Boolean;
217			i: integer;
218			begin
219			try
220			{ prevent modification of vital data structures while handling events }
221			EnterCriticalSection( CS);
222			ProcessingEvents := true;
223			isc_event_counts( StatusVector, EventBufferLen, EventBuffer, ResultBuffer);
224			CancelAlerts := false;
225			if assigned(FOnEventAlert) and not Changing then
226			begin
227			for i := 0 to Events.Count-1 do
228			begin
229			try
230			Status := StatusVectorArray;
231			if (Status[i] <> 0) and not CancelAlerts then
232			FOnEventAlert( self, Events[Events.Count-i-1], Status[i], CancelAlerts);
233			except
234			Application.HandleException( nil);
235			end;
236			end;
237			end;
238			Changing := false;
239			if not CancelAlerts and FQueued then DoQueueEvents;
240			finally
241			ProcessingEvents := false;
242			LeaveCriticalSection( CS);
243			end;
244			end;
245
246			procedure TIBEvents.Loaded;
247			begin
248			inherited Loaded;
249			try
250			if RegisteredState then RegisterEvents;
251			except
252			if csDesigning in ComponentState then
253			Application.HandleException( self)
254			else raise;
255			end;
256			end;
257
258			procedure TIBEvents.Notification( AComponent: TComponent;
259			Operation: TOperation);
260			begin
261			inherited Notification( AComponent, Operation);
262			if (Operation = opRemove) and (AComponent = FDatabase) then
263			begin
264			UnregisterEvents;
265			FDatabase := nil;
266			end;
267			end;
268
269			procedure TIBEvents.QueueEvents;
270			begin
271			if not FRegistered then
272			IBError(ibxeNoEventsRegistered, [nil]);
273			if ProcessingEvents then
274			IBError(ibxeInvalidQueueing, [nil]);
275			if not FQueued then
276			begin
277			try
278			{ wait until current event handler is finished before queuing events }
279			EnterCriticalSection( CS);
280			DoQueueEvents;
281			Changing := true;
282			finally
283			LeaveCriticalSection( CS);
284			end;
285			end;
286			end;
287
288			procedure TIBEvents.RegisterEvents;
289			var
290			i: integer;
291			bufptr: pointer;
292			eventbufptr: pointer;
293			resultbufptr: pointer;
294			buflen: integer;
295			begin
296			ValidateDatabase( Database);
297			if csDesigning in ComponentState then FRegistered := true
298			else begin
299			UnregisterEvents;
300			if Events.Count = 0 then exit;
301			for i := 0 to Events.Count-1 do
302			StrPCopy( @Buffer[i][0], Events[i]);
303			i := Events.Count;
304			bufptr := @buffer[0];
305			eventbufptr := @EventBuffer;
306			resultBufPtr := @ResultBuffer;
307			asm
308			mov ecx, dword ptr [i]
309			mov eax, dword ptr [bufptr]
310			@@1:
311			push eax
312			add eax, EventLength
313			loop @@1
314			push dword ptr [i]
315			push dword ptr [resultBufPtr]
316			push dword ptr [eventBufPtr]
317			call [isc_event_block]
318			mov dword ptr [bufLen], eax
319			mov eax, dword ptr [i]
320			shl eax, 2
321			add eax, 12
322			add esp, eax
323			end;
324			EventBufferlen := Buflen;
325			FRegistered := true;
326			QueueEvents;
327			end;
328			end;
329
330			procedure TIBEvents.SetEvents( value: TStrings);
331			begin
332			FEvents.Assign( value);
333			end;
334
335			procedure TIBEvents.SetDatabase( value: TIBDatabase);
336			begin
337			if value <> FDatabase then
338			begin
339			UnregisterEvents;
340			if assigned( value) and value.Connected then ValidateDatabase( value);
341			FDatabase := value;
342			end;
343			end;
344
345			procedure TIBEvents.SetRegistered( value: Boolean);
346			begin
347			if (csReading in ComponentState) then
348			RegisteredState := value
349			else if FRegistered <> value then
350			if value then RegisterEvents else UnregisterEvents;
351			end;
352
353			procedure TIBEvents.UnregisterEvents;
354			begin
355			if ProcessingEvents then
356			IBError(ibxeInvalidRegistration, [nil]);
357			if csDesigning in ComponentState then
358			FRegistered := false
359			else if not (csLoading in ComponentState) then
360			begin
361			CancelEvents;
362			if FRegistered then
363			begin
364			isc_free( EventBuffer);
365			EventBuffer := nil;
366			isc_free( ResultBuffer);
367			ResultBuffer := nil;
368			end;
369			FRegistered := false;
370			end;
371			end;
372
373			procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
374			var
375			i: integer;
376			begin
377			for i := 0 to length-1 do
378			ResultBuffer[i] := updated[i];
379			end;
380
381			end.