tpsystools_4.04/source/StPtrns.pas

// Upgraded to Delphi 2009: Sebastian Zierer

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (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.mozilla.org/MPL/
 *
 * 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 is TurboPower SysTools
 *
 * The Initial Developer of the Original Code is
 * TurboPower Software
 *
 * Portions created by the Initial Developer are Copyright (C) 1996-2002
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 *
 * ***** END LICENSE BLOCK ***** *)

{*********************************************************}
{* SysTools: StPtrns.pas 4.04                            *}
{*********************************************************}
{* SysTools: Pattern Classes                             *}
{*********************************************************}

{$include StDefine.inc}

unit StPtrns;

interface

uses
  Windows, SysUtils, Classes;

{------ S I N G L E T O N ---------------------}
type
  TStSingleton = class(TObject)
    private
      FRefCount : integer;
    protected
    public
      class function NewInstance : TObject; override;
      procedure FreeInstance; override;

      procedure AllocResources; virtual;
      procedure FreeResources; virtual;
  end;

{------ M E D I A T O R ------------------------}
type
  TStMediatorAction = procedure(aInputData, aResultData : TObject) of object;

  TStMediator = class
    private
      FEventTable : TStringList;
    protected
      function  GetCount : Integer;

    public
      constructor Create;
      destructor  Destroy; override;

      procedure Add(const aEventName : string; aHandler : TStMediatorAction);
      procedure Remove(const aEventName : string);

      procedure Handle(const aEventName : string; aInputData, aResultData : TObject);
      function  IsHandled(const aEventName : string) : boolean;

      property  Count : Integer read GetCount;
  end;

{-------O B S E R V E R  ------------------------}
type
  TStObserverAction = procedure(aInputData : TObject) of object;

  TStObserver = class
    private
      FEventTable : TList;
    protected
      function  GetObserver(Index : Integer) : TStObserverAction;
      procedure SetObserver(Index : Integer; InObserver : TStObserverAction);
      function  GetCount : Integer;

    public
      constructor Create;
      destructor  Destroy; override;

      procedure Add(aHandler : TStObserverAction);
      procedure Remove(aIndex : Integer);
      procedure Notify(aInputData : TObject);
      property  Handler[aIndex : Integer] : TStObserverAction
                   read GetObserver write SetObserver;
      property  Count : Integer read GetCount;
  end;

{------- C H A I N ---------------------------------}
type
  TStChainAction = procedure(aInputData, aResultData : TObject; var aStopNow : boolean) of object;

  TStChain = class
    private
      FEventTable : TList;
    protected
      function  GetHandler(Index : Integer) : TStChainAction;
      procedure SetHandler(Index : Integer; InHandler : TStChainAction);
      function  GetCount : Integer;

    public
      constructor Create;
      destructor  Destroy; override;

      procedure Add(aHandler : TStChainAction);
      procedure Remove(aIndex : Integer);
      procedure Handle(aInputData, aResultData : TObject);
      procedure Insert(aIndex : Integer; aHandler : TStChainAction);
      property Handler[aIndex : Integer] : TStChainAction
                  read GetHandler write SetHandler;
      property  Count : Integer read GetCount;
  end;

{====================================================================}
{====================================================================}
implementation

{------ S I N G L E T O N ---------------------}

var
  Instances : TStringList;
  SingletonLock : TRTLCriticalSection;

procedure TStSingleton.AllocResources;
begin
  {nothing at this level}
end;
{--------}

procedure TStSingleton.FreeInstance;
var
  Temp : pointer;
  Inx  : integer;
begin
  EnterCriticalSection(SingletonLock);
  try
    dec(FRefCount);
    if (FRefCount = 0) then begin
      FreeResources;
      Temp := Self;
      CleanupInstance;
      if Instances.Find(ClassName, Inx) then
        Instances.Delete(Inx);
      FreeMem(Temp);
    end;
  finally
    LeaveCriticalSection(SingletonLock);
  end;
end;
{--------}
procedure TStSingleton.FreeResources;
begin
  {nothing at this level}
end;
{--------}
class function TStSingleton.NewInstance : TObject;
var
  Inx : integer;
begin
  EnterCriticalSection(SingletonLock);
  try
    if not Instances.Find(ClassName, Inx) then begin
      GetMem(pointer(Result), InstanceSize);
      InitInstance(Result);
      Instances.AddObject(ClassName, Result);
      TStSingleton(Result).AllocResources;
    end
    else
      Result := Instances.Objects[Inx];
    inc(TStSingleton(Result).FRefCount);
  finally
    LeaveCriticalSection(SingletonLock);
  end;
end;
{====================================================================}

{------ M E D I A T O R ------------------------}
{The action holder is a class that encapsulates the action method}
type
  TStMedActionHolder = class(TObject)
    private
      FAction : TStMediatorAction;
    public
      property Action : TStMediatorAction read FAction write FAction;
  end;
{--------}
constructor TStMediator.Create;
begin
  inherited Create;
  FEventTable := TStringList.Create;
  FEventTable.Sorted := true;
end;

destructor TStMediator.Destroy;
var
  i : integer;
begin
  if (FEventTable <> nil) then begin
    for i := 0 to pred(FEventTable.Count) do
      FEventTable.Objects[i].Free;
    FEventTable.Free;
  end;
  inherited Destroy;
end;

procedure TStMediator.Add(const aEventName : string; aHandler : TStMediatorAction);
var
  MedAction : TStMedActionHolder;
begin
  MedAction := TStMedActionHolder.Create;
  MedAction.Action := aHandler;
  if (FEventTable.AddObject(aEventName, MedAction) = -1) then begin
    MedAction.Free;
    raise Exception.Create(
             Format('TStMediator.Add: event name [%s] already exists',
                    [aEventName]));
  end;
end;

function TStMediator.GetCount : Integer;
begin
  Result := FEventTable.Count;
end;

procedure TStMediator.Handle(const aEventName : string; aInputData, aResultData : TObject);
var
  Index : Integer;
  MediatorActionHolder : TStMedActionHolder;
begin
  Index := FEventTable.IndexOf(aEventName);
  if (Index < 0) then
    raise Exception.Create(
             Format('TStMediator.Handle: event name [%s] not found',
                    [aEventName]));
  MediatorActionHolder := TStMedActionHolder(FEventTable.Objects[Index]);
  MediatorActionHolder.Action(aInputData, aResultData);
end;

function  TStMediator.IsHandled(const aEventName : string) : boolean;
var
  Index : Integer;
begin
  Result := FEventTable.Find(aEventName, Index);
end;

procedure TStMediator.Remove(const aEventName : string);
var
  Index : Integer;
begin
  Index := FEventTable.IndexOf(aEventName);
  if (Index >= 0) then begin
    FEventTable.Objects[Index].Free;
    FEventTable.Delete(Index);
  end;
end;
{====================================================================}

{-------O B S E R V E R  ------------------------}
{The action holder is a class that encapsulates the action method}
type
  TStObActionHolder = class(TObject)
    private
      FAction : TStObserverAction;
    public
      property Action : TStObserverAction read FAction write FAction;
  end;
{--------}
constructor TStObserver.Create;
begin
  inherited Create;
  FEventTable := TList.Create;
end;

destructor TStObserver.Destroy;
var
  i : integer;
begin
  if (FEventTable <> nil) then begin
    for i := 0 to pred(FEventTable.Count) do
      TStObActionHolder(FEventTable[i]).Free;
    FEventTable.Free;
  end;
  inherited Destroy;
end;

procedure TStObserver.Add(aHandler : TStObserverAction);
var
  ObsAction : TStObActionHolder;
begin
  ObsAction := TStObActionHolder.Create;
  try
    ObsAction.Action := aHandler;
    FEventTable.Add(TObject(ObsAction));
  except
    ObsAction.Free;
    raise;
  end;
end;

function TStObserver.GetCount : Integer;
begin
  Result := FEventTable.Count;
end;

function TStObserver.GetObserver(Index : Integer) : TStObserverAction;
var
  ObserverHolder : TStObActionHolder;
begin
  Assert((Index >= 0) and (Index < FEventTable.Count),
         Format('TStObserver.GetObserver: Invalid index value: %d', [Index]));
  ObserverHolder := TStObActionHolder(FEventTable.Items[Index]);
  Result := ObserverHolder.Action;
end;

procedure TStObserver.Notify(aInputData : TObject);
var
  Index : integer;
  ObserverHolder : TStObActionHolder;
begin
  for Index := 0 to FEventTable.Count-1 do begin
    ObserverHolder := TStObActionHolder(FEventTable.Items[Index]);
    ObserverHolder.Action(aInputData);
  end;
end;

procedure TStObserver.Remove(aIndex : Integer);
begin
  Assert((aIndex >= 0) and (aIndex < FEventTable.Count),
         Format('TStObserver.Remove: Invalid index value: %d', [aIndex]));
  TStObActionHolder(FEventTable.Items[aIndex]).Free;
  FEventTable.Delete(aIndex);
end;

procedure TStObserver.SetObserver(Index : Integer;
  InObserver : TStObserverAction);
begin
  Assert((Index >= 0) and (Index < FEventTable.Count),
         Format('TStObserver.SetObserver: Invalid index value: %d', [Index]));
  TStObActionHolder(FEventTable.Items[Index]).Action := InObserver;
end;
{====================================================================}

{------- C H A I N ---------------------------------}
{The action holder is a class that encapsulates the action method}
type
  TStChActionHolder = class(TObject)
    private
      FAction : TStChainAction;
    public
      property Action : TStChainAction read FAction write FAction;
  end;
{--------}
constructor TStChain.Create;
begin
  inherited Create;
  FEventTable := TList.create;
end;

destructor TStChain.Destroy;
var
  i : integer;
begin
  if (FEventTable <> nil) then begin
    for i := 0 to pred(FEventTable.Count) do
      TStChActionHolder(FEventTable[i]).Free;
    FEventTable.Free;
  end;
  inherited Destroy;
end;

procedure TStChain.Add(aHandler : TStChainAction);
var
  ChainAction : TStChActionHolder;
begin
  ChainAction := TStChActionHolder.Create;
  try
    ChainAction.Action := aHandler;
    FEventTable.Add(TObject(ChainAction));
  except
    ChainAction.Free;
    raise;
  end;
end;

function TStChain.GetCount : Integer;
begin
  Result := FEventTable.Count;
end;

function TStChain.GetHandler(Index : Integer) : TStChainAction;
var
  ChainAction : TStChActionHolder;
begin
  Assert((Index >= 0) and (Index < FEventTable.Count),
         Format('TStChain.GetHandler: Invalid index value: %d', [Index]));
  ChainAction := TStChActionHolder(FEventTable.Items[Index]);
  Result := ChainAction.Action;
end;

procedure TStChain.Handle(aInputData, aResultData : TObject);
var
  Index : integer;
  Stop  : boolean;
  ChainAction : TStChActionHolder;
begin
  Stop := false;

  for Index := 0 to (FEventTable.Count - 1) do begin
    ChainAction := TStChActionHolder(FEventTable.Items[Index]);
    ChainAction.Action(aInputData, aResultData, Stop);
    if Stop then
      Exit;
  end;
end;

procedure TStChain.Insert(aIndex : integer; aHandler : TStChainAction);
var
  ChainAction : TStChActionHolder;
begin
  ChainAction := TStChActionHolder.Create;
  try
    ChainAction.Action := aHandler;
    FEventTable.Insert(aIndex, ChainAction);
  except
    ChainAction.Free;
    raise;
  end;
end;

procedure TStChain.Remove(aIndex : Integer);
begin
  Assert((aIndex >= 0) and (aIndex < FEventTable.Count),
         Format('TStChain.Remove: Invalid index value: %d', [aIndex]));
  TStChActionHolder(FEventTable.Items[aIndex]).Free;
  FEventTable.Delete(aIndex);
end;

procedure TStChain.SetHandler(Index : Integer; InHandler : TStChainAction);
begin
  Assert((Index >= 0) and (Index < FEventTable.Count),
         Format('TStObserver.SetObserver: Invalid index value: %d', [Index]));
  TStChActionHolder(FEventTable.Items[Index]).Action := InHandler;
end;

procedure InitUnit;
begin
  InitializeCriticalSection(SingletonLock);
  Instances := TStringList.Create;
  Instances.Sorted := true;
end;

procedure DoneUnit;
var
  i : integer;
  OldCount : integer;
begin
  EnterCriticalSection(SingletonLock);

  {continue 'freeing' the last singleton object in the Instances
   stringlist until its FreeInstance method actually frees the object
   and removes the class name from the stringlist: we detect this
   condition by the fact that the number of items in the stringlist
   decreases.}
  OldCount := Instances.Count;
  for i := pred(OldCount) downto 0 do begin
    repeat
      Instances.Objects[i].Free;
    until (Instances.Count <> OldCount);
    OldCount := Instances.Count;
  end;

  {free the global variables}
  Instances.Free;
  DeleteCriticalSection(SingletonLock);
end;

initialization
  InitUnit;

finalization
  DoneUnit;

end.

1	// Upgraded to Delphi 2009: Sebastian Zierer
2
3	(* *** BEGIN LICENSE BLOCK ***
4	* Version: MPL 1.1
5	*
6	* The contents of this file are subject to the Mozilla Public License Version
7	* 1.1 (the "License"); you may not use this file except in compliance with
8	* the License. You may obtain a copy of the License at
9	* http://www.mozilla.org/MPL/
10	*
11	* Software distributed under the License is distributed on an "AS IS" basis,
12	* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13	* for the specific language governing rights and limitations under the
14	* License.
15	*
16	* The Original Code is TurboPower SysTools
17	*
18	* The Initial Developer of the Original Code is
19	* TurboPower Software
20	*
21	* Portions created by the Initial Developer are Copyright (C) 1996-2002
22	* the Initial Developer. All Rights Reserved.
23	*
24	* Contributor(s):
25	*
26	* *** END LICENSE BLOCK *** *)
27
28	{*********************************************************}
29	{* SysTools: StPtrns.pas 4.04 *}
30	{*********************************************************}
31	{* SysTools: Pattern Classes *}
32	{*********************************************************}
33
34	{$include StDefine.inc}
35
36	unit StPtrns;
37
38	interface
39
40	uses
41	Windows, SysUtils, Classes;
42
43	{------ S I N G L E T O N ---------------------}
44	type
45	TStSingleton = class(TObject)
46	private
47	FRefCount : integer;
48	protected
49	public
50	class function NewInstance : TObject; override;
51	procedure FreeInstance; override;
52
53	procedure AllocResources; virtual;
54	procedure FreeResources; virtual;
55	end;
56
57	{------ M E D I A T O R ------------------------}
58	type
59	TStMediatorAction = procedure(aInputData, aResultData : TObject) of object;
60
61	TStMediator = class
62	private
63	FEventTable : TStringList;
64	protected
65	function GetCount : Integer;
66
67	public
68	constructor Create;
69	destructor Destroy; override;
70
71	procedure Add(const aEventName : string; aHandler : TStMediatorAction);
72	procedure Remove(const aEventName : string);
73
74	procedure Handle(const aEventName : string; aInputData, aResultData : TObject);
75	function IsHandled(const aEventName : string) : boolean;
76
77	property Count : Integer read GetCount;
78	end;
79
80	{-------O B S E R V E R ------------------------}
81	type
82	TStObserverAction = procedure(aInputData : TObject) of object;
83
84	TStObserver = class
85	private
86	FEventTable : TList;
87	protected
88	function GetObserver(Index : Integer) : TStObserverAction;
89	procedure SetObserver(Index : Integer; InObserver : TStObserverAction);
90	function GetCount : Integer;
91
92	public
93	constructor Create;
94	destructor Destroy; override;
95
96	procedure Add(aHandler : TStObserverAction);
97	procedure Remove(aIndex : Integer);
98	procedure Notify(aInputData : TObject);
99	property Handler[aIndex : Integer] : TStObserverAction
100	read GetObserver write SetObserver;
101	property Count : Integer read GetCount;
102	end;
103
104	{------- C H A I N ---------------------------------}
105	type
106	TStChainAction = procedure(aInputData, aResultData : TObject; var aStopNow : boolean) of object;
107
108	TStChain = class
109	private
110	FEventTable : TList;
111	protected
112	function GetHandler(Index : Integer) : TStChainAction;
113	procedure SetHandler(Index : Integer; InHandler : TStChainAction);
114	function GetCount : Integer;
115
116	public
117	constructor Create;
118	destructor Destroy; override;
119
120	procedure Add(aHandler : TStChainAction);
121	procedure Remove(aIndex : Integer);
122	procedure Handle(aInputData, aResultData : TObject);
123	procedure Insert(aIndex : Integer; aHandler : TStChainAction);
124	property Handler[aIndex : Integer] : TStChainAction
125	read GetHandler write SetHandler;
126	property Count : Integer read GetCount;
127	end;
128
129	{====================================================================}
130	{====================================================================}
131	implementation
132
133	{------ S I N G L E T O N ---------------------}
134
135	var
136	Instances : TStringList;
137	SingletonLock : TRTLCriticalSection;
138
139	procedure TStSingleton.AllocResources;
140	begin
141	{nothing at this level}
142	end;
143	{--------}
144
145	procedure TStSingleton.FreeInstance;
146	var
147	Temp : pointer;
148	Inx : integer;
149	begin
150	EnterCriticalSection(SingletonLock);
151	try
152	dec(FRefCount);
153	if (FRefCount = 0) then begin
154	FreeResources;
155	Temp := Self;
156	CleanupInstance;
157	if Instances.Find(ClassName, Inx) then
158	Instances.Delete(Inx);
159	FreeMem(Temp);
160	end;
161	finally
162	LeaveCriticalSection(SingletonLock);
163	end;
164	end;
165	{--------}
166	procedure TStSingleton.FreeResources;
167	begin
168	{nothing at this level}
169	end;
170	{--------}
171	class function TStSingleton.NewInstance : TObject;
172	var
173	Inx : integer;
174	begin
175	EnterCriticalSection(SingletonLock);
176	try
177	if not Instances.Find(ClassName, Inx) then begin
178	GetMem(pointer(Result), InstanceSize);
179	InitInstance(Result);
180	Instances.AddObject(ClassName, Result);
181	TStSingleton(Result).AllocResources;
182	end
183	else
184	Result := Instances.Objects[Inx];
185	inc(TStSingleton(Result).FRefCount);
186	finally
187	LeaveCriticalSection(SingletonLock);
188	end;
189	end;
190	{====================================================================}
191
192	{------ M E D I A T O R ------------------------}
193	{The action holder is a class that encapsulates the action method}
194	type
195	TStMedActionHolder = class(TObject)
196	private
197	FAction : TStMediatorAction;
198	public
199	property Action : TStMediatorAction read FAction write FAction;
200	end;
201	{--------}
202	constructor TStMediator.Create;
203	begin
204	inherited Create;
205	FEventTable := TStringList.Create;
206	FEventTable.Sorted := true;
207	end;
208
209	destructor TStMediator.Destroy;
210	var
211	i : integer;
212	begin
213	if (FEventTable <> nil) then begin
214	for i := 0 to pred(FEventTable.Count) do
215	FEventTable.Objects[i].Free;
216	FEventTable.Free;
217	end;
218	inherited Destroy;
219	end;
220
221	procedure TStMediator.Add(const aEventName : string; aHandler : TStMediatorAction);
222	var
223	MedAction : TStMedActionHolder;
224	begin
225	MedAction := TStMedActionHolder.Create;
226	MedAction.Action := aHandler;
227	if (FEventTable.AddObject(aEventName, MedAction) = -1) then begin
228	MedAction.Free;
229	raise Exception.Create(
230	Format('TStMediator.Add: event name [%s] already exists',
231	[aEventName]));
232	end;
233	end;
234
235	function TStMediator.GetCount : Integer;
236	begin
237	Result := FEventTable.Count;
238	end;
239
240	procedure TStMediator.Handle(const aEventName : string; aInputData, aResultData : TObject);
241	var
242	Index : Integer;
243	MediatorActionHolder : TStMedActionHolder;
244	begin
245	Index := FEventTable.IndexOf(aEventName);
246	if (Index < 0) then
247	raise Exception.Create(
248	Format('TStMediator.Handle: event name [%s] not found',
249	[aEventName]));
250	MediatorActionHolder := TStMedActionHolder(FEventTable.Objects[Index]);
251	MediatorActionHolder.Action(aInputData, aResultData);
252	end;
253
254	function TStMediator.IsHandled(const aEventName : string) : boolean;
255	var
256	Index : Integer;
257	begin
258	Result := FEventTable.Find(aEventName, Index);
259	end;
260
261	procedure TStMediator.Remove(const aEventName : string);
262	var
263	Index : Integer;
264	begin
265	Index := FEventTable.IndexOf(aEventName);
266	if (Index >= 0) then begin
267	FEventTable.Objects[Index].Free;
268	FEventTable.Delete(Index);
269	end;
270	end;
271	{====================================================================}
272
273	{-------O B S E R V E R ------------------------}
274	{The action holder is a class that encapsulates the action method}
275	type
276	TStObActionHolder = class(TObject)
277	private
278	FAction : TStObserverAction;
279	public
280	property Action : TStObserverAction read FAction write FAction;
281	end;
282	{--------}
283	constructor TStObserver.Create;
284	begin
285	inherited Create;
286	FEventTable := TList.Create;
287	end;
288
289	destructor TStObserver.Destroy;
290	var
291	i : integer;
292	begin
293	if (FEventTable <> nil) then begin
294	for i := 0 to pred(FEventTable.Count) do
295	TStObActionHolder(FEventTable[i]).Free;
296	FEventTable.Free;
297	end;
298	inherited Destroy;
299	end;
300
301	procedure TStObserver.Add(aHandler : TStObserverAction);
302	var
303	ObsAction : TStObActionHolder;
304	begin
305	ObsAction := TStObActionHolder.Create;
306	try
307	ObsAction.Action := aHandler;
308	FEventTable.Add(TObject(ObsAction));
309	except
310	ObsAction.Free;
311	raise;
312	end;
313	end;
314
315	function TStObserver.GetCount : Integer;
316	begin
317	Result := FEventTable.Count;
318	end;
319
320	function TStObserver.GetObserver(Index : Integer) : TStObserverAction;
321	var
322	ObserverHolder : TStObActionHolder;
323	begin
324	Assert((Index >= 0) and (Index < FEventTable.Count),
325	Format('TStObserver.GetObserver: Invalid index value: %d', [Index]));
326	ObserverHolder := TStObActionHolder(FEventTable.Items[Index]);
327	Result := ObserverHolder.Action;
328	end;
329
330	procedure TStObserver.Notify(aInputData : TObject);
331	var
332	Index : integer;
333	ObserverHolder : TStObActionHolder;
334	begin
335	for Index := 0 to FEventTable.Count-1 do begin
336	ObserverHolder := TStObActionHolder(FEventTable.Items[Index]);
337	ObserverHolder.Action(aInputData);
338	end;
339	end;
340
341	procedure TStObserver.Remove(aIndex : Integer);
342	begin
343	Assert((aIndex >= 0) and (aIndex < FEventTable.Count),
344	Format('TStObserver.Remove: Invalid index value: %d', [aIndex]));
345	TStObActionHolder(FEventTable.Items[aIndex]).Free;
346	FEventTable.Delete(aIndex);
347	end;
348
349	procedure TStObserver.SetObserver(Index : Integer;
350	InObserver : TStObserverAction);
351	begin
352	Assert((Index >= 0) and (Index < FEventTable.Count),
353	Format('TStObserver.SetObserver: Invalid index value: %d', [Index]));
354	TStObActionHolder(FEventTable.Items[Index]).Action := InObserver;
355	end;
356	{====================================================================}
357
358	{------- C H A I N ---------------------------------}
359	{The action holder is a class that encapsulates the action method}
360	type
361	TStChActionHolder = class(TObject)
362	private
363	FAction : TStChainAction;
364	public
365	property Action : TStChainAction read FAction write FAction;
366	end;
367	{--------}
368	constructor TStChain.Create;
369	begin
370	inherited Create;
371	FEventTable := TList.create;
372	end;
373
374	destructor TStChain.Destroy;
375	var
376	i : integer;
377	begin
378	if (FEventTable <> nil) then begin
379	for i := 0 to pred(FEventTable.Count) do
380	TStChActionHolder(FEventTable[i]).Free;
381	FEventTable.Free;
382	end;
383	inherited Destroy;
384	end;
385
386	procedure TStChain.Add(aHandler : TStChainAction);
387	var
388	ChainAction : TStChActionHolder;
389	begin
390	ChainAction := TStChActionHolder.Create;
391	try
392	ChainAction.Action := aHandler;
393	FEventTable.Add(TObject(ChainAction));
394	except
395	ChainAction.Free;
396	raise;
397	end;
398	end;
399
400	function TStChain.GetCount : Integer;
401	begin
402	Result := FEventTable.Count;
403	end;
404
405	function TStChain.GetHandler(Index : Integer) : TStChainAction;
406	var
407	ChainAction : TStChActionHolder;
408	begin
409	Assert((Index >= 0) and (Index < FEventTable.Count),
410	Format('TStChain.GetHandler: Invalid index value: %d', [Index]));
411	ChainAction := TStChActionHolder(FEventTable.Items[Index]);
412	Result := ChainAction.Action;
413	end;
414
415	procedure TStChain.Handle(aInputData, aResultData : TObject);
416	var
417	Index : integer;
418	Stop : boolean;
419	ChainAction : TStChActionHolder;
420	begin
421	Stop := false;
422
423	for Index := 0 to (FEventTable.Count - 1) do begin
424	ChainAction := TStChActionHolder(FEventTable.Items[Index]);
425	ChainAction.Action(aInputData, aResultData, Stop);
426	if Stop then
427	Exit;
428	end;
429	end;
430
431	procedure TStChain.Insert(aIndex : integer; aHandler : TStChainAction);
432	var
433	ChainAction : TStChActionHolder;
434	begin
435	ChainAction := TStChActionHolder.Create;
436	try
437	ChainAction.Action := aHandler;
438	FEventTable.Insert(aIndex, ChainAction);
439	except
440	ChainAction.Free;
441	raise;
442	end;
443	end;
444
445	procedure TStChain.Remove(aIndex : Integer);
446	begin
447	Assert((aIndex >= 0) and (aIndex < FEventTable.Count),
448	Format('TStChain.Remove: Invalid index value: %d', [aIndex]));
449	TStChActionHolder(FEventTable.Items[aIndex]).Free;
450	FEventTable.Delete(aIndex);
451	end;
452
453	procedure TStChain.SetHandler(Index : Integer; InHandler : TStChainAction);
454	begin
455	Assert((Index >= 0) and (Index < FEventTable.Count),
456	Format('TStObserver.SetObserver: Invalid index value: %d', [Index]));
457	TStChActionHolder(FEventTable.Items[Index]).Action := InHandler;
458	end;
459
460	procedure InitUnit;
461	begin
462	InitializeCriticalSection(SingletonLock);
463	Instances := TStringList.Create;
464	Instances.Sorted := true;
465	end;
466
467	procedure DoneUnit;
468	var
469	i : integer;
470	OldCount : integer;
471	begin
472	EnterCriticalSection(SingletonLock);
473
474	{continue 'freeing' the last singleton object in the Instances
475	stringlist until its FreeInstance method actually frees the object
476	and removes the class name from the stringlist: we detect this
477	condition by the fact that the number of items in the stringlist
478	decreases.}
479	OldCount := Instances.Count;
480	for i := pred(OldCount) downto 0 do begin
481	repeat
482	Instances.Objects[i].Free;
483	until (Instances.Count <> OldCount);
484	OldCount := Instances.Count;
485	end;
486
487	{free the global variables}
488	Instances.Free;
489	DeleteCriticalSection(SingletonLock);
490	end;
491
492	initialization
493	InitUnit;
494
495	finalization
496	DoneUnit;
497
498	end.
499