DelphiでSingletonパターンを実装する(リベンジ)

DelphiでSingletonパターンを実装する(再考)ではTSingletonのインスタンスの解放を防ぐためにデストラクタ内で例外を送出する、という方法を考えてみましたが、２ちゃんねる界隈では不評だったようです。一般論からいえば確かにデストラクタからの例外の送出はいかがなものか、という気もしますが、そもそもこのアプローチは(コンストラクタからの例外の送出による複数インスタンスの生成の防止と同様に)テストレベルで問題コードを検出、修正するためのものであって、リリースコード上で実行されることを想定しているわけではありません。また前回考察したように、一旦呼び出しがなされたコンストラクタ、デストラクタのインスタンスに対する生成、破棄処理を回避するには例外の送出しかないことも確かです。ということで"より望ましい"解決方法を考えてみることにします。

まず前回の"Phoenix Singleton"ですが、デストラクタを呼び出すことでインスタンスが完全に解放されてしまうため、次回のアクセスで新しいインスタンスが生成されてもその内容は初期状態に戻ってしまいます。そこで"予備"のインスタンスを用意しておき、ここに内容を退避して再生成時に復元します。まずinitialization/finalization版から。

unit Unit32;

interface

uses
  SysUtils;

type
  TSingleton = class(TObject)
  private
    FTestValue: Integer;
    constructor CreateInstance;
  public
    constructor Create;
    destructor  Destroy; override;
    procedure   Assign(Source: TSingleton);
    class function GetInstance: TSingleton;
    property    TestValue: Integer
                  read  FTestValue
                  write FTestValue;
  end;

  ECreateSingleton = class(Exception)
  end;


implementation

var
  FSingleton: TSingleton;
  FShadowSingleton: TSingleton;

{ TSingleton }

constructor TSingleton.Create;
begin

  raise ECreateSingleton.Create('TSingleton.Create cannot use.');

end;

constructor TSingleton.CreateInstance;
begin

  inherited Create;

  { Initialize }
  FTestValue := 0;

end;

destructor TSingleton.Destroy;
begin

  { Shadowing }
  if FShadowSingleton = nil then
  begin
    FShadowSingleton := TSingleton.CreateInstance;
  end;
  if FShadowSingleton <> Self then
  begin
    FShadowSingleton.Assign(Self);

    { Delete singleton reference }
    FSingleton := nil;
  end;

  { Finalize }

  inherited;

end;

procedure TSingleton.Assign(Source: TSingleton);
begin

  { Copy from source }
  TestValue := Source.TestValue;

end;

class function TSingleton.GetInstance: TSingleton;
begin

  if FSingleton = nil then
  begin
    FSingleton := TSingleton.CreateInstance;
    if FShadowSingleton <> nil then
    begin
      FSingleton.Assign(FShadowSingleton);
    end;
  end;

  Result := FSingleton;

end;

initialization
  FSingleton := nil;
  FShadowSingleton := nil;

finalization
  FSingleton.Free;
  FShadowSingleton.Free;

end.

Object Pascal

次にclass constructor/class destructor版です。

unit Unit34;

interface

uses
  SysUtils;

type
  TSingleton = class(TObject)
  private
    FTestValue: Integer;
    class var
      FSingleton: TSingleton;
      FShadowSingleton: TSingleton;
    constructor CreateInstance;
  public
    class constructor Create;
    class destructor  Destroy;
    constructor Create;
    destructor  Destroy; override;
    procedure   Assign(Source: TSingleton);
    class function GetInstance: TSingleton;
    property    TestValue: Integer
                  read  FTestValue
                  write FTestValue;
  end;

  ECreateSingleton = class(Exception)
  end;


implementation

{ TSingleton }

class constructor TSingleton.Create;
begin

  FSingleton := nil;
  FShadowSingleton := nil;

end;

class destructor TSingleton.Destroy;
begin

  FSingleton.Free;
  FShadowSingleton.Free;

end;

constructor TSingleton.Create;
begin

  raise ECreateSingleton.Create('TSingleton.Create cannot use.');

end;

constructor TSingleton.CreateInstance;
begin

  inherited Create;

  { Initialize }
  FTestValue := 0;

end;

destructor TSingleton.Destroy;
begin

  { Shadowing }
  if FShadowSingleton = nil then
  begin
    FShadowSingleton := TSingleton.CreateInstance;
  end;
  if FShadowSingleton <> Self then
  begin
    FShadowSingleton.Assign(Self);

    { Delete singleton reference }
    FSingleton := nil;
  end;

  { Finalize }

  inherited;

end;

procedure TSingleton.Assign(Source: TSingleton);
begin

  { Copy from source }
  TestValue := Source.TestValue;

end;

class function TSingleton.GetInstance: TSingleton;
begin

  if FSingleton = nil then
  begin
    FSingleton := TSingleton.CreateInstance;
    if FShadowSingleton <> nil then
    begin
      FSingleton.Assign(FShadowSingleton);
    end;
  end;

  Result := FSingleton;

end;

end.

Object Pascal

いずれもシングルトンの内容の退避、復帰のためにインスタンスの内容をコピーするprocedure Assignというメソッドを用意し、これをコンストラクタ、デストラクタで使用します。なおシングルトンが別のクラスのインスタンスを所有するような場合、Assignはいわゆる"deep copy"の動作を実装する必要があります。またpublicなconstructor Createについてはとりあえず従来どおりの例外送出のままとしてあります。

次にコンストラクタ、デストラクタでの例外の送出、というアプローチですが、これは前述のとおりテストレベルでの問題コードの検出、修正を目的としています。しかしこの方法には問題コードが実行されない限り意味をもたない(コンパイル時には検出できない)、という欠点もあります。そこで例外の送出ではなく、constructor Create、destructor Destory、そして再定義したprocedure Freeに(少々目的は異なるものの)ヒント指令のdeprecatedを指定しておき、これらを呼び出しているコードをコンパイル時に警告されるようにする、という解決策を考えてみます。まずinitialization/finalization版から。

unit Unit28;

interface

uses
  SysUtils;

type
  TSingleton = class(TObject)
  private
    FTestValue: Integer;
    constructor CreateInstance;
    destructor  DestroyInstance;
  public
    constructor Create;            deprecated {$IFDEF CONDITIONALEXPRESSIONS}{$IF CompilerVersion >= 20.00} 'Do not use TSingleton.Create.'  {$IFEND}{$ENDIF};
    destructor  Destroy; override; deprecated {$IFDEF CONDITIONALEXPRESSIONS}{$IF CompilerVersion >= 20.00} 'Do not use TSingleton.Destory.' {$IFEND}{$ENDIF};
    procedure   Free;              deprecated {$IFDEF CONDITIONALEXPRESSIONS}{$IF CompilerVersion >= 20.00} 'Do not use TSingleton.Free.'    {$IFEND}{$ENDIF};
    class function GetInstance: TSingleton;
    property    TestValue: Integer
                  read  FTestValue
                  write FTestValue;
  end;


implementation

var
  FSingleton: TSingleton;

{ TSingleton }

constructor TSingleton.Create;
begin

  { Place holder, do not use }

end;

destructor TSingleton.Destroy;
begin

  { Place holder, do not use }

end;

constructor TSingleton.CreateInstance;
begin

  inherited Create;

  { Initialize }
  FTestValue := 0;

end;

destructor TSingleton.DestroyInstance;
begin

  { Finalize }

  inherited Destroy;

end;

procedure TSingleton.Free;
begin

  { Place holder, do not use }

end;

class function TSingleton.GetInstance: TSingleton;
begin

  if FSingleton = nil then
  begin
    FSingleton := TSingleton.CreateInstance;
  end;

  Result := FSingleton;

end;

initialization
  FSingleton := nil;

finalization
  if FSingleton <> nil then
  begin
    FSingleton.DestroyInstance;
  end;

end.

Object Pascal

Delphi 2009以降({$IFDEF CONDITIONALEXPRESSIONS}{$IF CompilerVersion >= 20.00}で判定)ではdeprecatedに追加のメッセージを指定しています。

次にclass constructor/class destructor版です。

unit Unit30;

interface

uses
  SysUtils;

type
  TSingleton = class(TObject)
  private
    FTestValue: Integer;
    class var
      FSingleton: TSingleton;
    constructor CreateInstance;
    destructor  DestroyInstance;
  public
    class constructor Create;
    class destructor  Destroy;
    constructor Create;            deprecated 'Do not use TSingleton.Create.';
    destructor  Destroy; override; deprecated 'Do not use TSingleton.Destory.';
    procedure   Free;              deprecated 'Do not use TSingleton.Free.';
    class function GetInstance: TSingleton;
    property    TestValue: Integer
                  read  FTestValue
                  write FTestValue;
  end;


implementation

{ TSingleton }

class constructor TSingleton.Create;
begin

  FSingleton := nil;

end;

class destructor TSingleton.Destroy;
begin

  if FSingleton <> nil then
  begin
    FSingleton.DestroyInstance;
  end;

end;

constructor TSingleton.Create;
begin

  { Place holder, do not use }

end;

destructor TSingleton.Destroy;
begin

  { Place holder, do not use }

end;

constructor TSingleton.CreateInstance;
begin

  inherited Create;

  { Initialize }
  FTestValue := 0;

end;

destructor TSingleton.DestroyInstance;
begin

  { Finalize }

  inherited Destroy;

end;

procedure TSingleton.Free;
begin

  { Place holder, do not use }

end;

class function TSingleton.GetInstance: TSingleton;
begin

  if FSingleton = nil then
  begin
    FSingleton := TSingleton.CreateInstance;
  end;

  Result := FSingleton;

end;

end.

Object Pascal

どちらもDelphi 2009以降であれば"プロジェクトオプション"の"Delphiコンパイラ"の"ヒントと警告"で"使用を推奨されていないシンボル"をエラーにするか、シングルトンを使用している側のユニットに

{$WARN SYMBOL_DEPRECATED ERROR}

Object Pascal

を指定することでconstructor Create、destructor Destory、procedure Freeの呼び出しをエラーにすることができます(通常は警告)。