Delphi单例模式

Question

我知道，在我所在的社区中，很多地方都在讨论这个问题，但我只是找不到一个在Delphi中实现Singleton模式的好方法。我在C#中有一个例子：

public sealed class Singleton {
  // Private Constructor
  Singleton() { }

  // Private object instantiated with private constructor
  static readonly Singleton instance = new Singleton();

  // Public static property to get the object
  public static Singleton UniqueInstance {
    get { return instance; }
  }
}

我知道在Delphi中没有这样优雅的解决方案，而且我看到了很多关于不能在Delphi中正确隐藏构造函数(使其为私有)的讨论，因此我们需要重写NewInstance和FreeInstance方法。我相信这方面的东西是我在ibeblog.com -“德尔福:单例模式”上找到的实现。

type
  TTestClass = class
  private
    class var FInstance: TTestClass;
  public                              
    class function GetInstance: TTestClass;
    class destructor DestroyClass;
  end;

{ TTestClass }
class destructor TTestClass.DestroyClass;
begin
  if Assigned(FInstance) then
    FInstance.Free;
end;

class function TTestClass.GetInstance: TTestClass;
begin
  if not Assigned(FInstance) then
    FInstance := TTestClass.Create;
  Result := FInstance;
end;

你对单例模式有什么建议？它能简单、优雅和线程安全吗？

谢谢。

Answer 1

我想，如果我想要一个没有任何构造方法的类似对象的东西，我可能会使用一个包含在一个单元的实现部分中的实现对象的接口。

我会通过一个全局函数(在接口部分中声明)公开接口。该实例将在最后一节中整理。

为了获得线程安全，我可以使用一个关键部分(或等效部分)，或者可能使用经过仔细实现的双重检查锁定，但认识到天真的实现只会因为x86内存模型的强大特性而起作用。

看起来会是这样的：

unit uSingleton;

interface

uses
  SyncObjs;

type
  ISingleton = interface
    procedure DoStuff;
  end;

function Singleton: ISingleton;

implementation

type
  TSingleton = class(TInterfacedObject, ISingleton)
  private
    procedure DoStuff;
  end;

{ TSingleton }

procedure TSingleton.DoStuff;
begin
end;

var
  Lock: TCriticalSection;
  _Singleton: ISingleton;

function Singleton: ISingleton;
begin
  Lock.Acquire;
  Try
    if not Assigned(_Singleton) then
      _Singleton := TSingleton.Create;
    Result := _Singleton;
  Finally
    Lock.Release;
  End;
end;

initialization
  Lock := TCriticalSection.Create;

finalization
  Lock.Free;

end.

Answer 2

有人提到，我应该在这里上发布我的答案。

有一种名为http://blogs.msdn.com/b/oldnewthing/archive/2011/04/07/10150728.aspx的技术可以做您想做的事情：

interface

function getInstance: TObject;

implementation

var
   AObject: TObject;

function getInstance: TObject;
var
   newObject: TObject;
begin
   if (AObject = nil) then
   begin
      //The object doesn't exist yet. Create one.
      newObject := TObject.Create;

      //It's possible another thread also created one.
      //Only one of us will be able to set the AObject singleton variable
      if InterlockedCompareExchangePointer(AObject, newObject, nil) <> nil then
      begin
         //The other beat us. Destroy our newly created object and use theirs.
         newObject.Free;
      end;
   end;

   Result := AObject;
end;

InterlockedCompareExchangePointer的使用在操作周围安装了一个完整的内存屏障。一个人有可能能够通过InterlockedCompareExchangePointerAcquire或InterlockedCompareExchangeRelease解决优化问题，只在之前或之后设置一个内存围栏。问题是：

• 我不知道是否获得了或发布的语义。
• 您正在构建一个对象，内存屏障性能的影响是您最不担心的(这是线程安全)

InterlockedCompareExchangePointer

Windows直到2003年左右才添加InterlockedCompareExchangePointer。实际上，它只是InterlockedCompareExchange的一个包装器。

function InterlockedCompareExchangePointer(var Destination: Pointer; Exchange: Pointer; Comparand: Pointer): Pointer stdcall;
const
    SPointerAlignmentError = 'Parameter to InterlockedCompareExchangePointer is not 32-bit aligned';
begin
{IFDEF Debug}
    //On 64-bit systems, the pointer must be aligned to 64-bit boundaries.
    //On 32-bit systems, the pointer must be aligned to 32-bit boundaries.
    if ((NativeInt(Destination) mod 4) <> 0)
            or ((NativeInt(Exchange) mod 4) <> 0)
            or ((NativeInt(Comparand) mod 4) <> 0) then
    begin
        OutputDebugString(SPointerAlignmentError);
        if IsDebuggerPresent then
            Windows.DebugBreak;
    end;
{ENDIF}
    Result := Pointer(IntPtr(InterlockedCompareExchange(Integer(IntPtr(Destination)), IntPtr(Exchange), IntPtr(Comparand))));
end;

在Windows.Winapi中，我发现XE6中32位的InterlockedcompareExchangePointer实现方式相同(除了安全检查之外)：

{$IFDEF WIN32}
function InterlockedCompareExchangePointer(var Destination: Pointer; Exchange: Pointer; Comparand: Pointer): Pointer; inline;
begin
  Result := Pointer(IntPtr(InterlockedCompareExchange(Integer(IntPtr(Destination)), IntPtr(Exchange), IntPtr(Comparand))));
end;
{$ENDIF}

在较新版本的Delphi中，您最好使用System.SyncObjs中的TInterlocked助手类。

if TInterlocked.CompareExchange({var}AObject, newObject, nil) <> nil then
begin
   //The other beat us. Destroy our newly created object and use theirs.
   newObject.Free;
end;

注意事项：发布到公共域中的任何代码。不需要归属。

Answer 3

德尔菲的问题在于，您总是从Create继承TObject构造函数。但我们可以很好地处理这件事！以下是一种方法：

TTrueSingleton = class
private
  class var FSingle: TTrueSingleton;
  constructor MakeSingleton;
public
  constructor Create;reintroduce;deprecated 'Don''t use this!';

  class function Single: TTrueSingleton;
end;

如您所见，我们可以有一个私有构造函数，并且可以隐藏继承的TObject.Create构造函数！在TTrueSingleton.Create的实现中，您可以引发一个错误(运行时块)，而deprecated关键字提供编译时错误处理的额外好处！

以下是实现部分：

constructor TTrueSingleton.Create;
begin
  raise Exception.Create('Don''t call me directly!');
end;

constructor TTrueSingleton.MakeSingleton;
begin
end;

class function TTrueSingleton.Single: TTrueSingleton;
begin
  if not Assigned(FSingle) then FSingle := TTrueSingleton.MakeSingleton;
  Result := FSingle;
end;

如果在编译时编译器看到您这样做：

var X: TTrueSingleton := TTrueSingleton.Create;

它将向您提供deprecated警告，并提供错误消息。如果您固执到忽略它，在运行时，您将不会得到一个对象，而是一个引发的异常。

稍后编辑来介绍线程安全.首先，我必须承认，对于我自己的代码，我不关心这种线程安全。两个线程在如此短的时间范围内访问我的单例创建者例程(它导致创建两个TTrueSingleton对象)的概率非常小，因此根本不值得使用所需的几行代码。

但是如果没有线程安全，这个答案是不完整的，所以下面是我对这个问题的看法。我将使用一个简单的自旋锁(繁忙等待)，因为当不需要执行锁定时，它是有效的；此外，它只锁定那些锁

为此，需要添加另一个类var：class var FLock: Integer。Singleton类函数应该如下所示：

class function TTrueSingleton.Single: TTrueSingleton;
var Tmp: TTrueSingleton;
begin
  MemoryBarrier; // Make sure all CPU caches are in sync
  if not Assigned(FSingle) then
  begin
    Assert(NativeUInt(@FLock) mod 4 = 0, 'FLock needs to be alligned to 32 bits.');

    // Busy-wait lock: Not a big problem for a singleton implementation
    repeat
    until InterlockedCompareExchange(FLock, 1, 0) = 0; // if FLock=0 then FLock:=1;
    try
      if not Assigned(FSingle) then
      begin 
        Tmp := TTrueSingleton.MakeSingleton;
        MemoryBarrier; // Second barrier, make sure all CPU caches are in sync.
        FSingle := Tmp; // Make sure the object is fully created when we assign it to FSingle.
      end;
    finally FLock := 0; // Release lock
    end;
  end;
  Result := FSingle;
end;