《GOF设计模式》—单件(Singleton)—Delphi源码示例：创建Singleton类的子类（使用注册表）

示例：创建Singleton类的子类（使用注册表）
说明：
一个更灵活的方法是使用一个单件注册表。可能的Singleton类的集合不是由Instance定义的，Singleton类可以根据名字在一个众所周知的注册表中注册它们的单件实例。
这个注册表在字符串名字和单件之间建立映射。当Instance需要一个单件时，它参考注册表，根据名字请求单件。注册表查询相应的单件（如果存在的话）并返回它。这个方法使得Instance不再需要知道所有可能的Singleton类或实例。它所需要的只是所有Singleton类的一个公共的接口，该接口包括了对注册表的操作。
Singleton类不再负责创建单件。它的主要职责是使得供选择的单件对象在系统中可以被访问。
代码：
unit uSingleton4;

interface

uses
SysUtils, Classes,Dialogs,IniFiles;

type
TSingletonClass = class of TSingleton;

TSingleton = class
private
class var
FInstance: TSingleton;
FRegistry: TStringList;
protected
class function Lookup(const AName:string):TSingleton;
public
constructor Create;
destructor Destroy; override;
//---
class procedure Register1(const AName:String;ASingleton:TSingletonClass);
class function Instance: TSingleton;
procedure Operate;virtual;
end;
TSingletonA = class(TSingleton)
public
procedure Operate; override;
end;
TSingletonB = class(TSingleton)
public
procedure Operate; override;
end;

implementation

constructor TSingleton.Create;
begin
if FInstance = nil then
FInstance := Self
else
abort;
end;

destructor TSingleton.Destroy;
begin
FInstance := nil;
//---
if FRegistry = nil then
FreeAndNil(FRegistry);
//---
inherited;
end;

class procedure TSingleton.Register1(const AName: String;
ASingleton: TSingletonClass);
begin
if FRegistry = nil then
FRegistry := TStringList.Create;
//---
with FRegistry do
begin
if IndexOf(AName) < 0 then
AddObject(AName,TObject(ASingleton));
end;
end;

class function TSingleton.Lookup(const AName: string): TSingleton;
var
i: Integer;
begin
i := FRegistry.IndexOf(AName);
if i >= 0 then
Result := TSingletonClass(FRegistry.Objects[i]).Create
else
Result := nil;
end;

class function TSingleton.Instance: TSingleton;
//---
function _getenv(const ADefaultName:string):string;
var
AFile: TIniFile;
begin
try
AFile := TIniFile.Create('Config.ini');
Result := AFile.ReadString('Singleton','Kind',ADefaultName);
AFile.Free;
except
Result := ADefaultName;
end;
end;
var
ASingletonName:string;
begin
if FInstance = nil then
begin
ASingletonName := _getenv('Singleton');
FInstance := Lookup(ASingletonName);
end;
//---
Result := FInstance;
end;

procedure TSingleton.Operate;
begin
ShowMessage('Singleton');
end;

procedure TSingletonA.Operate;
begin
ShowMessage('SingletonA');
end;

procedure TSingletonB.Operate;
begin
ShowMessage('SingletonB');
end;

initialization
TSingleton.Register1('Singleton',TSingleton);
TSingleton.Register1('SingletonA',TSingletonA);
TSingleton.Register1('SingletonB',TSingletonB);

end.

procedure TForm1.Button5Click(Sender: TObject);
begin
TSingleton.Instance.Operate;
TSingleton.Instance.Free;
end;