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, 9 months ago) by tony
Content type:	text/x-pascal
File size:	10491 byte(s)
Log Message:	Committing updates for Release pre-release
#	Content
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	{$Mode Delphi}
32
33	interface
34
35	uses
36	{$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
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	function HandleEvent( param: pointer): ptrint;
121	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	EndThread;
129	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	BeginThread( @HandleEvent,ptr);
138	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	InitCriticalSection( CS);
148	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	DoneCriticalSection( CS);
165	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	EventNames: array of PChar;
296	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	setlength(EventNames,Events.Count);
303	for i := 0 to Events.Count-1 do
304	EventNames[i] := PChar(Events[i]);
305
306	EventBufferlen := isc_event_block(@EventBuffer,@ResultBuffer,
307	Events.Count,EventNames);
308	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.