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	torben	2671	// 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