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;

{$Mode Delphi}

interface

uses
{$IFDEF LINUX }
  {$IFNDEF DESIGNTIME} cthreads,{$ENDIF}unix,
{$ELSE}
  Windows,
{$ENDIF}  Classes, Graphics, Controls,
  Forms, Dialogs, 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;
    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 }

function HandleEvent( param: pointer): ptrint;
begin
  { don't let exceptions propogate out of thread }
  try
    TIBEvents( param).HandleEvent;
  except
    Application.HandleException( nil);
  end;
  EndThread;
end;

procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
begin
  { Handle events asynchronously in second thread }
  EnterCriticalSection( TIBEvents( ptr).CS);
  TIBEvents( ptr).UpdateResultBuffer( length, updated);
  if TIBEvents( ptr).Queued then
    BeginThread( @HandleEvent,ptr);
  LeaveCriticalSection( TIBEvents( ptr).CS);
end;

constructor TIBEvents.Create( AOwner: TComponent);
begin
  inherited Create( AOwner);
  FIBLoaded := False;
  CheckIBLoaded;
  FIBLoaded := True;
  InitCriticalSection( 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;
    DoneCriticalSection( 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;
  EventNames: array of PChar;
begin
  ValidateDatabase( Database);
  if csDesigning in ComponentState then FRegistered := true
  else begin
    UnregisterEvents;
    if Events.Count = 0 then exit;
    setlength(EventNames,Events.Count);
    for i := 0 to Events.Count-1 do
      EventNames[i] := PChar(Events[i]);

    EventBufferlen := isc_event_block(@EventBuffer,@ResultBuffer,
                        Events.Count,EventNames);
    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:	5
Committed:	Fri Feb 18 16:26:16 2011 UTC (13 years, 2 months ago) by tony
Content type:	text/x-pascal
File size:	10491 byte(s)
Log Message:	Committing updates for Release pre-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	tony	5	{$Mode Delphi}
32
33	tony	1	interface
34
35			uses
36	tony	5	{$IFDEF LINUX }
37			{$IFNDEF DESIGNTIME} cthreads,{$ENDIF}unix,
38			{$ELSE}
39			Windows,
40			{$ENDIF} Classes, Graphics, Controls,
41			Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;
42	tony	1
43			const
44			MaxEvents = 15;
45			EventLength = 64;
46
47			type
48
49			TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
50			var CancelAlerts: Boolean) of object;
51
52			TEventBuffer = array[ 0..MaxEvents-1, 0..EventLength-1] of char;
53
54			TIBEvents = class(TComponent)
55			private
56			FIBLoaded: Boolean;
57			FEvents: TStrings;
58			FOnEventAlert: TEventAlert;
59			FQueued: Boolean;
60			FRegistered: Boolean;
61			Changing: Boolean;
62			CS: TRTLCriticalSection;
63			EventBuffer: PChar;
64			EventBufferLen: integer;
65			EventID: ISC_LONG;
66			ProcessingEvents: Boolean;
67			RegisteredState: Boolean;
68			ResultBuffer: PChar;
69			FDatabase: TIBDatabase;
70			procedure SetDatabase( value: TIBDatabase);
71			procedure ValidateDatabase( Database: TIBDatabase);
72			procedure DoQueueEvents;
73			procedure EventChange( sender: TObject);
74			procedure UpdateResultBuffer( length: short; updated: PChar);
75			protected
76			procedure HandleEvent;
77			procedure Loaded; override;
78			procedure Notification( AComponent: TComponent; Operation: TOperation); override;
79			procedure SetEvents( value: TStrings);
80			procedure SetRegistered( value: boolean);
81			function GetNativeHandle: TISC_DB_HANDLE;
82
83			public
84			constructor Create( AOwner: TComponent); override;
85			destructor Destroy; override;
86			procedure CancelEvents;
87			procedure QueueEvents;
88			procedure RegisterEvents;
89			procedure UnRegisterEvents;
90			property Queued: Boolean read FQueued;
91			published
92			property Database: TIBDatabase read FDatabase write SetDatabase;
93			property Events: TStrings read FEvents write SetEvents;
94			property Registered: Boolean read FRegistered write SetRegistered;
95			property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
96			end;
97
98			implementation
99
100			uses
101			IBIntf;
102
103			function TIBEvents.GetNativeHandle: TISC_DB_HANDLE;
104			begin
105			if assigned( FDatabase) and FDatabase.Connected then
106			Result := FDatabase.Handle
107			else result := nil;
108			end;
109
110			procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
111			begin
112			if not assigned( Database) then
113			IBError(ibxeDatabaseNameMissing, [nil]);
114			if not Database.Connected then
115			IBError(ibxeDatabaseClosed, [nil]);
116			end;
117
118			{ TIBEvents }
119
120	tony	5	function HandleEvent( param: pointer): ptrint;
121	tony	1	begin
122			{ don't let exceptions propogate out of thread }
123			try
124			TIBEvents( param).HandleEvent;
125			except
126			Application.HandleException( nil);
127			end;
128	tony	5	EndThread;
129	tony	1	end;
130
131			procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
132			begin
133			{ Handle events asynchronously in second thread }
134			EnterCriticalSection( TIBEvents( ptr).CS);
135			TIBEvents( ptr).UpdateResultBuffer( length, updated);
136			if TIBEvents( ptr).Queued then
137	tony	5	BeginThread( @HandleEvent,ptr);
138	tony	1	LeaveCriticalSection( TIBEvents( ptr).CS);
139			end;
140
141			constructor TIBEvents.Create( AOwner: TComponent);
142			begin
143			inherited Create( AOwner);
144			FIBLoaded := False;
145			CheckIBLoaded;
146			FIBLoaded := True;
147	tony	5	InitCriticalSection( CS);
148	tony	1	FEvents := TStringList.Create;
149			with TStringList( FEvents) do
150			begin
151			OnChange := EventChange;
152			Duplicates := dupIgnore;
153			end;
154			end;
155
156			destructor TIBEvents.Destroy;
157			begin
158			if FIBLoaded then
159			begin
160			UnregisterEvents;
161			SetDatabase( nil);
162			TStringList(FEvents).OnChange := nil;
163			FEvents.Free;
164	tony	5	DoneCriticalSection( CS);
165	tony	1	end;
166			inherited Destroy;
167			end;
168
169			procedure TIBEvents.CancelEvents;
170			begin
171			if ProcessingEvents then
172			IBError(ibxeInvalidCancellation, [nil]);
173			if FQueued then
174			begin
175			try
176			{ wait for event handler to finish before cancelling events }
177			EnterCriticalSection( CS);
178			ValidateDatabase( Database);
179			FQueued := false;
180			Changing := true;
181			if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
182			IBDatabaseError;
183			finally
184			LeaveCriticalSection( CS);
185			end;
186			end;
187			end;
188
189			procedure TIBEvents.DoQueueEvents;
190			var
191			callback: pointer;
192			begin
193			ValidateDatabase( DataBase);
194			callback := @IBEventCallback;
195			if (isc_que_events( StatusVector, @FDatabase.Handle, @EventID, EventBufferLen,
196			EventBuffer, TISC_CALLBACK(callback), PVoid(Self)) > 0) then
197			IBDatabaseError;
198			FQueued := true;
199			end;
200
201			procedure TIBEvents.EventChange( sender: TObject);
202			begin
203			{ check for blank event }
204			if TStringList(Events).IndexOf( '') <> -1 then
205			IBError(ibxeInvalidEvent, [nil]);
206			{ check for too many events }
207			if Events.Count > MaxEvents then
208			begin
209			TStringList(Events).OnChange := nil;
210			Events.Delete( MaxEvents);
211			TStringList(Events).OnChange := EventChange;
212			IBError(ibxeMaximumEvents, [nil]);
213			end;
214			if Registered then RegisterEvents;
215			end;
216
217			procedure TIBEvents.HandleEvent;
218			var
219			Status: PStatusVector;
220			CancelAlerts: Boolean;
221			i: integer;
222			begin
223			try
224			{ prevent modification of vital data structures while handling events }
225			EnterCriticalSection( CS);
226			ProcessingEvents := true;
227			isc_event_counts( StatusVector, EventBufferLen, EventBuffer, ResultBuffer);
228			CancelAlerts := false;
229			if assigned(FOnEventAlert) and not Changing then
230			begin
231			for i := 0 to Events.Count-1 do
232			begin
233			try
234			Status := StatusVectorArray;
235			if (Status[i] <> 0) and not CancelAlerts then
236			FOnEventAlert( self, Events[Events.Count-i-1], Status[i], CancelAlerts);
237			except
238			Application.HandleException( nil);
239			end;
240			end;
241			end;
242			Changing := false;
243			if not CancelAlerts and FQueued then DoQueueEvents;
244			finally
245			ProcessingEvents := false;
246			LeaveCriticalSection( CS);
247			end;
248			end;
249
250			procedure TIBEvents.Loaded;
251			begin
252			inherited Loaded;
253			try
254			if RegisteredState then RegisterEvents;
255			except
256			if csDesigning in ComponentState then
257			Application.HandleException( self)
258			else raise;
259			end;
260			end;
261
262			procedure TIBEvents.Notification( AComponent: TComponent;
263			Operation: TOperation);
264			begin
265			inherited Notification( AComponent, Operation);
266			if (Operation = opRemove) and (AComponent = FDatabase) then
267			begin
268			UnregisterEvents;
269			FDatabase := nil;
270			end;
271			end;
272
273			procedure TIBEvents.QueueEvents;
274			begin
275			if not FRegistered then
276			IBError(ibxeNoEventsRegistered, [nil]);
277			if ProcessingEvents then
278			IBError(ibxeInvalidQueueing, [nil]);
279			if not FQueued then
280			begin
281			try
282			{ wait until current event handler is finished before queuing events }
283			EnterCriticalSection( CS);
284			DoQueueEvents;
285			Changing := true;
286			finally
287			LeaveCriticalSection( CS);
288			end;
289			end;
290			end;
291
292			procedure TIBEvents.RegisterEvents;
293			var
294			i: integer;
295	tony	5	EventNames: array of PChar;
296	tony	1	begin
297			ValidateDatabase( Database);
298			if csDesigning in ComponentState then FRegistered := true
299			else begin
300			UnregisterEvents;
301			if Events.Count = 0 then exit;
302	tony	5	setlength(EventNames,Events.Count);
303	tony	1	for i := 0 to Events.Count-1 do
304	tony	5	EventNames[i] := PChar(Events[i]);
305
306			EventBufferlen := isc_event_block(@EventBuffer,@ResultBuffer,
307			Events.Count,EventNames);
308	tony	1	FRegistered := true;
309			QueueEvents;
310			end;
311			end;
312
313			procedure TIBEvents.SetEvents( value: TStrings);
314			begin
315			FEvents.Assign( value);
316			end;
317
318			procedure TIBEvents.SetDatabase( value: TIBDatabase);
319			begin
320			if value <> FDatabase then
321			begin
322			UnregisterEvents;
323			if assigned( value) and value.Connected then ValidateDatabase( value);
324			FDatabase := value;
325			end;
326			end;
327
328			procedure TIBEvents.SetRegistered( value: Boolean);
329			begin
330			if (csReading in ComponentState) then
331			RegisteredState := value
332			else if FRegistered <> value then
333			if value then RegisterEvents else UnregisterEvents;
334			end;
335
336			procedure TIBEvents.UnregisterEvents;
337			begin
338			if ProcessingEvents then
339			IBError(ibxeInvalidRegistration, [nil]);
340			if csDesigning in ComponentState then
341			FRegistered := false
342			else if not (csLoading in ComponentState) then
343			begin
344			CancelEvents;
345			if FRegistered then
346			begin
347			isc_free( EventBuffer);
348			EventBuffer := nil;
349			isc_free( ResultBuffer);
350			ResultBuffer := nil;
351			end;
352			FRegistered := false;
353			end;
354			end;
355
356			procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
357			var
358			i: integer;
359			begin
360			for i := 0 to length-1 do
361			ResultBuffer[i] := updated[i];
362			end;
363
364			end.