XPSingleton.pas
上传用户:yjb1804
上传日期:2021-01-30
资源大小:3105k
文件大小:11k
源码类别:

Email服务器

开发平台:

Delphi

  1. unit XPSingleton;
  2. {.$DEFINE DBG_XPSINGLETON}
  3. {
  4.  $Source: /cvsroot/dunit/dunit/Contrib/DUnitWizard/Source/Common/XPSingleton.pas,v $
  5.  $Revision: 1.1 $
  6.  $Date: 2004/05/03 15:07:15 $
  7.  Last amended by $Author: pvspain $
  8.  $State: Exp $
  9.  Implementation of thread-safe singleton as a TObject descendant and
  10.  a TInterfacedObject descendant.
  11.  Copyright (c) 2001 by The Excellent Programming Company Pty Ltd
  12.  (Australia) (ABN 27 005 394 918).
  13.  Contact Paul Spain via email: paul@xpro.com.au
  14.  This unit is free software; you can redistribute it and/or
  15.  modify it under the terms of the GNU Lesser General Public
  16.  License as published by the Free Software Foundation; either
  17.  version 2.1 of the License, or (at your option) any later version.
  18.  This unit is distributed in the hope that it will be useful,
  19.  but WITHOUT ANY WARRANTY; without even the implied warranty of
  20.  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21.  Lesser General Public License for more details.
  22.  You should have received a copy of the GNU Lesser General Public
  23.  License along with this unit; if not, the license can be viewed at:
  24.  http://www.gnu.org/copyleft/lesser.html
  25.  or write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  26.  Boston, MA  02111-1307  USA
  27. }
  28. interface
  29. { TODO: Long term. May need to investigate better solution than TStringList
  30.   for registration if performance is an issue. }
  31. uses
  32.   XPSyncRW,             // IXPSyncRW,
  33.   XPWinSync,            // CreateThreadRWSynchroniser()
  34.   XPStrings;         // IXPStrings, CreateXPStrings()
  35. type
  36. //////////////////////////////////////////////////////////////////////////////
  37. //    TXPSingleton declaration
  38. //////////////////////////////////////////////////////////////////////////////
  39.   TXPSingleton = class(TObject)
  40.     private
  41.     FRefCount: integer;
  42.     { Local references to file scope objects kept to stop premature
  43.       disappearance of implementing objects after unit finalization occurs. }
  44.     FSingletons: IXPStrings;
  45.     FSync: IXPSyncRW;
  46.     function GetRefCount: integer;
  47.     function GetIsSoleRef: boolean;
  48. {$IFDEF DBG_XPSINGLETON}
  49. class procedure DumpYaGuts;
  50. {$ENDIF}
  51.     public
  52.     class function NewInstance: TObject; override;
  53.     procedure AfterConstruction; override;
  54.     procedure BeforeDestruction; override;
  55.     destructor Destroy; override;
  56.     procedure FreeInstance; override;
  57.     property RefCount: integer read GetRefCount;
  58.   { You must reference <IsSoleRef> property in your subclass constructor.
  59.     If <IsSoleRef> is true, you need to execute any code you may have in your
  60.     subclass constructor. If false, you don't need to execute your code, as
  61.     it has been executed in a previous constructor call.
  62.     You must also reference <IsSoleRef> property in your subclass destructor.
  63.     If <IsSoleRef> is true, you need to execute any code you may have in your
  64.     subclass destructor. If false, you don't need to execute your code, as
  65.     there are remaining references to the singleton. }
  66.     property IsSoleRef: boolean read GetIsSoleRef;
  67.     end;
  68. //////////////////////////////////////////////////////////////////////////////
  69. //    TXPInterfacedSingleton declaration
  70. //////////////////////////////////////////////////////////////////////////////
  71.   TXPInterfacedSingleton = class(TInterfacedObject, IUnknown)
  72.     private
  73.     { Local references to file scope objects kept to stop premature
  74.       disappearance of implementing objects after unit finalization occurs. }
  75.     FSingletons: IXPStrings;
  76.     FSync: IXPSyncRW;
  77.     function GetIsSoleRef: boolean;
  78.     function GetRefCount: integer;
  79.     public
  80.     class function NewInstance: TObject; override;
  81.     procedure AfterConstruction; override;
  82.     destructor Destroy; override;
  83.     function _AddRef: Integer; stdcall;
  84.     function _Release: Integer; stdcall;
  85.     { Hides inherited property. }
  86.     property RefCount: integer read GetRefCount;
  87.   { You must reference <IsSoleRef> property in your subclass constructor.
  88.     If <IsSoleRef> is true, you need to execute any code you may have in your
  89.     subclass constructor. If false, you don't need to execute your code, as
  90.     it has been executed in a previous constructor call.
  91.     Unlike TXPSingleton, you needn't reference <IsSoleRef> property in your
  92.     subclass destructor. The destructor should never be called explicitly, and
  93.     will only be invoked when the last reference disappears, so any destructor
  94.     code should be executed for every invocation of Destroy(). }
  95.     property IsSoleRef: boolean read GetIsSoleRef;
  96.     end;
  97. implementation
  98. {$IFDEF DBG_XPSINGLETON}
  99. uses
  100.   PVDLU,        // PVDL.Diagnostic;
  101.   SysUtils;
  102. var
  103.   fGOSingletons, fGISingletons: IXPStrings;
  104.   fGOSync, fGISync: IXPSyncRW;
  105. {$ELSE}
  106. var
  107.   GOSingletons, GISingletons: IXPStrings;
  108.   GOSync, GISync: IXPSyncRW;
  109. {$ENDIF}
  110. const
  111.   CVSID: string ='$Header: /cvsroot/dunit/dunit/Contrib/DUnitWizard/Source/Common/XPSingleton.pas,v 1.1 2004/05/03 15:07:15 pvspain Exp $';
  112. {$IFDEF DBG_XPSINGLETON}
  113. function GOSingletons: IXPStrings;
  114.   begin
  115.   if fGOSingletons = nil then
  116.     fGOSingletons := CreateXPStrings(true);
  117.   Result := fGOSingletons;
  118.   end;
  119. function GISingletons: IXPStrings;
  120.   begin
  121.   if fGISingletons = nil then
  122.     fGISingletons := CreateXPStrings(true);
  123.   Result := fGISingletons;
  124.   end;
  125. function GOSync: IXPSyncRW;
  126.   begin
  127.   if fGOSync = nil then
  128.     fGOSync := CreateThreadRWSynchroniser;
  129.   Result := fGOSync;
  130.   end;
  131. function GISync: IXPSyncRW;
  132.   begin
  133.   if fGISync = nil then
  134.     fGISync := CreateThreadRWSynchroniser;
  135.   Result := fGISync;
  136.   end;
  137. {$ENDIF}
  138. //////////////////////////////////////////////////////////////////////////////
  139. //    TXPSingleton implementation
  140. //////////////////////////////////////////////////////////////////////////////
  141. {$IFDEF DBG_XPSINGLETON}
  142. class procedure TXPSingleton.DumpYaGuts;
  143.   var
  144.   idx: integer;
  145.   msg: string;
  146.   begin
  147.   msg := 'TXPSingleton: Refs:';
  148.   for idx := 0 to GOSingletons.Strings.Count - 1 do
  149.     msg := SysUtils.Format('%s %s %d', [msg, GOSingletons.Strings[idx],
  150.         TXPSingleton(GOSingletons.Strings.Objects[idx]).RefCount]);
  151.   PVDL.Diagnostic.Post(msg);
  152.   end;
  153. {$ENDIF}
  154. class function TXPSingleton.NewInstance: TObject;
  155.   var
  156.   idx: integer;
  157.   begin
  158.   { Entry point for construction process.
  159.     Note that we are accessing the filescope references here (GOSync and
  160.     GOSingletons), as the member equivalents won't be established yet
  161.     for new instances. }
  162.   GOSync.WriteBegin;
  163.   idx := GOSingletons.Strings.IndexOf(ClassName);
  164.   if idx <> -1 then
  165.     { Previous instance. Return singleton. }
  166.     Result := GOSingletons.Strings.Objects[idx]
  167.   else
  168.     begin
  169. {$IFDEF DBG_XPSINGLETON}
  170.     DumpYaGuts;
  171.     PVDL.Diagnostic.PostFmt('TXPSingleton: Adding %s', [ClassName]);
  172. {$ENDIF}
  173.     { First instance. Allocate memory *and* initialise - InitInstance
  174.       is called by inherited method. }
  175.     Result := inherited NewInstance;
  176.     { Register class name and associated instance. }
  177.     GOSingletons.Strings.AddObject(ClassName, Result);
  178.     { Allocate instance data. }
  179.     TXPSingleton(Result).FSingletons := GOSingletons;
  180.     TXPSingleton(Result).FSync := GOSync;
  181.     end;
  182.   { Increment reference count. }
  183.   System.Inc(TXPSingleton(Result).FRefCount);
  184. end;
  185. procedure TXPSingleton.AfterConstruction;
  186.   begin
  187.   { Exit point for construction process. }
  188.   GOSync.WriteEnd;
  189.   end;
  190. procedure TXPSingleton.BeforeDestruction;
  191.   begin
  192.   { Entry point for destruction process. }
  193.   FSync.WriteBegin;
  194.   end;
  195. destructor TXPSingleton.Destroy;
  196.   begin
  197.   System.Dec(FRefCount);
  198.     if FRefCount = 0 then
  199.       begin
  200.       with FSingletons.Strings do Delete(IndexOf(self.ClassName));
  201.       inherited Destroy;
  202.       end;
  203.   end;
  204. procedure TXPSingleton.FreeInstance;
  205.   begin
  206.   { Exit point for destruction process. }
  207.   { Release memory only when all references gone. }
  208.   if RefCount = 0 then
  209.     begin
  210.     FSync.WriteEnd;
  211. {$IFDEF DBG_XPSINGLETON}
  212.     PVDL.Diagnostic.PostFmt('TXPSingleton: Deleting %s', [ClassName]);
  213.     DumpYaGuts;
  214. {$ENDIF}
  215.     inherited FreeInstance;
  216.     end
  217.   else
  218.     FSync.WriteEnd;
  219.   end;
  220. function TXPSingleton.GetRefCount: integer;
  221.   begin
  222.   Result := FRefCount;
  223.   end;
  224. function TXPSingleton.GetIsSoleRef: boolean;
  225.   begin
  226.   FSync.ReadBegin;
  227.   try
  228.     Result := (RefCount = 1);
  229.   finally
  230.     FSync.ReadEnd;
  231.     end;
  232.   end;
  233. //////////////////////////////////////////////////////////////////////////////
  234. //    TXPInterfacedSingleton implementation
  235. //////////////////////////////////////////////////////////////////////////////
  236. class function TXPInterfacedSingleton.NewInstance: TObject;
  237.   var
  238.   idx: integer;
  239.   begin
  240.   { Entry point for construction process.
  241.     Note that we are accessing the filescope references here (GISync and
  242.     GISingletons), as the member equivalents won't be established yet
  243.     for new instances. }
  244.   GISync.WriteBegin;
  245.   idx := GISingletons.Strings.IndexOf(ClassName);
  246.   if idx <> -1 then
  247.     begin
  248.     { Previous instance. Return singleton. }
  249.     Result := GISingletons.Strings.Objects[idx];
  250.     { Increment ref count, as TInterfacedObject.AfterConstruction() decrements
  251.       value by 1. No need to inc ref count otherwise, as this is done by
  252.       TInterfacedObject._AddRef() mechanism. }
  253.     System.Inc(TXPInterfacedSingleton(Result).FRefCount);
  254.     end
  255.   else
  256.     begin
  257.     { First instance. Allocate memory and initialise. }
  258.     Result := inherited NewInstance;
  259.     { Register class type and associated instance. }
  260.     GISingletons.Strings.AddObject(ClassName, Result);
  261.     { Allocate instance data. }
  262.     TXPInterfacedSingleton(Result).FSingletons := GISingletons;
  263.     TXPInterfacedSingleton(Result).FSync := GISync;
  264.     end;
  265.   end;
  266. procedure TXPInterfacedSingleton.AfterConstruction;
  267.   begin
  268.   { Exit point for construction process. }
  269.   inherited;
  270.   GISync.WriteEnd;
  271.   end;
  272. destructor TXPInterfacedSingleton.Destroy;
  273.   begin
  274.   with FSingletons.Strings do Delete(IndexOf(self.ClassName));
  275.   inherited;
  276.   end;
  277. function TXPInterfacedSingleton.GetIsSoleRef: boolean;
  278.   begin
  279.   { RefCount = 1 within the context of a constructor, or after the first
  280.     assignment. RefCount = 0 for a constructed object that hasn't been
  281.     assigned to an interface. }
  282.   Result := (RefCount = 0) or (RefCount = 1);
  283.   end;
  284. function TXPInterfacedSingleton.GetRefCount: integer;
  285.   begin
  286.   FSync.ReadBegin;
  287.   Result := FRefCount;
  288.   FSync.ReadEnd;
  289.   end;
  290. function TXPInterfacedSingleton._AddRef: Integer;
  291.   begin
  292.   FSync.WriteBegin;
  293.   System.Inc(FRefCount);
  294.   Result := FRefCount;
  295.   FSync.WriteEnd;
  296.   end;
  297. function TXPInterfacedSingleton._Release: Integer;
  298.   begin
  299.   FSync.WriteBegin;
  300.   System.Dec(FRefCount);
  301.   Result := FRefCount;
  302.   FSync.WriteEnd;
  303.   if Result = 0 then
  304.     Destroy;
  305.   end;
  306. {$IFNDEF DBG_XPSINGLETON}
  307. initialization
  308.   GOSync := CreateThreadRWSynchroniser;
  309.   GISync := CreateThreadRWSynchroniser;
  310.   { Sort IXPStrings to improve lookup response. }
  311.   GOSingletons := CreateXPStrings(true);
  312.   GISingletons := CreateXPStrings(true);
  313. {$ENDIF}
  314. end.